[clouchdb-cvs] CVS clouchdb/src

[peddy]

Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv9477/src

Modified Files:
	tests.lisp clouchdb.lisp 
Log Message:
Support for utf-8 encoded document IDs


--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2007/12/17 23:18:07	1.4
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2007/12/18 17:26:56	1.5
@@ -337,6 +337,17 @@
   (ensure-same (document-property :_id (get-document "http://google.com")) "http://google.com"))
 
 (addtest (clouchdb-doc-api-tests)
+  (:documentation "Test encoding and decoding of utf-8 document IDs")
+  encode-document-utf-8-ids
+  (ensure 
+   (let ((ids '("Ångström Café" "σπασμένα" "我能吞下玻璃而不伤身体")))
+     (reduce #'(lambda (a b) (and a b))
+             (mapcar #'(lambda (id)
+                         (and (document-property :ok (create-document nil :id id))
+                              (equal id (document-property :_id (get-document id)))))
+                     ids)))))
+
+(addtest (clouchdb-doc-api-tests)
   (:documentation "Test document content encoding by creating a
   document with a field for a variety of languages, then fetching that
   document and comparing the fecthed data with the source data") 
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2007/12/18 02:16:02	1.7
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2007/12/18 17:26:56	1.8
@@ -162,27 +162,34 @@
     out))
 
 (defmacro cat (&rest rest)
-  "Silly shorthand for (concatenate 'string)"
+  "Shorthand for (concatenate 'string)"
   `(concatenate 'string , at rest))
 
 (defun doublequote (value)
   "Wrap specified value in double quotes."
   (cat "\"" value "\""))
 
+(defun convert-encoding (string encoding)
+  "Convert string to specified encoding. This may be totally wrong and
+probably way too inefficient, but it seems to work."
+  (octets-to-string (string-to-octets string :external-format encoding)))
+
 (defun url-encode (string)
   "URL-encode a string."
   (with-output-to-string (s)
-    (loop for c across string
+    (loop for c across (convert-encoding string +utf-8+)
           do (cond ((or (char<= #\0 c #\9)
                         (char<= #\a c #\z)
                         (char<= #\A c #\Z)
                         (find c "$-_.!*'()," :test #'char=))
                      (write-char c s))
                    ((char= c #\Space)
-                     (write-char #\+ s))
+                     (write-string "%20" s))
                    (t (format s "%~2,'0x" (char-code c)))))))
 
 (defun make-uri (&rest rest)
+  "Return a URI containing *protocol*://*host*:*port*/ and the
+concatenation of the remaining parameters."
   (concatenate 'string *protocol* "://" *host* ":" *port* "/"
 	       (apply #'concatenate 'string rest)))
 
@@ -205,13 +212,6 @@
 		      :uri (make-uri dbn)))))
        ,result)))
 
-;; (defmacro handle-doc-errors (&body body)
-;;   (let ((result (gensym)))
-;;     `(let ((,result (progn , at body)))
-;;        (when (document-property :error (,result))
-;;          (cond ((equal "conflict" (document-property :error result))
-;;                 (error 'id-or-revision-conflict 
-               
 (defun document-to-json (doc)
   "Convert document data, the top-level of wich is either an
   associative list or hashtable, to json data"
@@ -254,7 +254,7 @@
 
 (defun db-request (uri &rest keys &key &allow-other-keys)
   "Used by all Couchdb APIs to make the actual REST request."
-;;  (format t "uri: ~S~% keys: ~S~%" (make-uri uri) keys)
+  ;;(format t "uri: ~S~% keys: ~S~%" (make-uri uri) keys)
   (let ((*text-content-types* *text-types*))
     (multiple-value-bind (body status headers uri stream must-close reason-phrase)
 	(apply #'drakma:http-request (make-uri uri) keys)
@@ -304,7 +304,7 @@
 ;;
 
 (defun list-dbs ()
-  "List all databases"
+  "Return a list of all databases for the current host and port."
   (db-request "_all_dbs" :method :get))
 
 (defun create-db (&key (db-name nil db-name-p) (if-exists :fail))
@@ -411,7 +411,8 @@
       (push (cons "revs" "true") parameters))
     (when revision-info
       (push (cons "revs_info" "true") parameters))
-    (let ((res (ensure-db () (db-request (cat (url-encode *db-name*) "/" (url-encode id))
+    (let ((res (ensure-db () (db-request (cat (url-encode *db-name*) "/" 
+                                              (url-encode id))
 					 :method :get 
 					 :parameters parameters))))
       (if (document-property :error res)
@@ -513,6 +514,8 @@
 (defun ad-hoc-view (view &rest options &key key start-key start-key-docid
                     end-key count update descending skip)
   "Execute query using an ad-hoc view."
+  (declare (ignore key start-key start-key-docid end-key count 
+                   update descending skip))
   (ensure-db ()
     (db-request (cat (url-encode *db-name*) "/_temp_view")
 		:method :post
@@ -557,8 +560,10 @@
 returns results in reverse order. If update is t, does not refresh
 view for query, use for higher performance but possible data
 inconsistency."
-  (declare (ignore key start-key start-key-docid end-key count update descending skip))
+  (declare (ignore key start-key start-key-docid end-key count 
+                   update descending skip))
   (ensure-db ()
-    (db-request (cat (url-encode *db-name*) "/_view/" (url-encode id) "/" (url-encode view))
+    (db-request (cat (url-encode *db-name*) "/_view/" 
+                     (url-encode id) "/" (url-encode view))
 		:method :get
                 :parameters (transform-params options *view-options*))))