[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Fri Dec 14 23:22:58 UTC 2007
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv19826/src
Modified Files:
clouchdb.lisp examples.lisp tests.lisp
Log Message:
Fixed document ID encoding bug, documentation now valid XHMTL
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/09 16:03:21 1.3
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/14 23:22:58 1.4
@@ -161,6 +161,19 @@
"Wrap specified value in double quotes."
(cat "\"" value "\""))
+(defun url-encode (string)
+ "URL-encode a string."
+ (with-output-to-string (s)
+ (loop for c across string
+ 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))
+ (t (format s "%~2,'0x" (char-code c)))))))
+
(defun make-uri (&rest rest)
(concatenate 'string *protocol* "://" *host* ":" *port* "/"
(apply #'concatenate 'string rest)))
@@ -222,7 +235,7 @@
(t (cdr (assoc name doc)))))
(defun (setf document-property) (value name doc)
- "Allows setting of document properties in place"
+ "Allows setting of document properties in place."
(cond ((hash-table-p doc)
(setf (gethash name doc) value))
(t (rplacd (assoc name doc) value)))
@@ -290,7 +303,7 @@
error condition is generated. Specify :recreate to potentially delete
and create a new database."
(let* ((name (if db-name-p db-name *db-name*))
- (res (db-request (cat name "/") :method :put)))
+ (res (db-request (cat (url-encode name) "/") :method :put)))
(if (equal "database_already_exists" (document-property :error res))
(ecase if-exists
((:ignore) (list (cons :ok t) (cons :ignored t)))
@@ -311,7 +324,7 @@
error condition, but this can be avoided by specifying :ignore in the
if-missing parameter."
(let* ((name (if db-name-p db-name *db-name*))
- (res (db-request (cat name "/") :method :delete)))
+ (res (db-request (cat (url-encode name) "/") :method :delete)))
(if (and (document-property :error res) (not (eq :ignore if-missing)))
(restart-case
(error 'db-does-not-exist
@@ -324,7 +337,7 @@
"Get information for named database, or couchdb server if no
database specified."
(let ((dbn (if db-name-p db-name *db-name*)))
- (db-request (cat dbn "/") :method :get)))
+ (db-request (cat (url-encode dbn) "/") :method :get)))
(defun create-temp-db-name ()
"Return a database name that's probably unique."
@@ -362,7 +375,7 @@
ascending ID order by default, or descending order of descending
parameter is non-nil."
(ensure-db ()
- (db-request (cat *db-name* "/_all_docs")
+ (db-request (cat (url-encode *db-name*) "/_all_docs")
:method :get
:parameters (if descending
;; ?descending=false causes error ATM
@@ -386,7 +399,7 @@
(push (cons "revs" "true") parameters))
(when revision-info
(push (cons "revs_info" "true") parameters))
- (let ((res (ensure-db () (db-request (cat *db-name* "/" id)
+ (let ((res (ensure-db () (db-request (cat (url-encode *db-name*) "/" (url-encode id))
:method :get
:parameters parameters))))
(if (document-property :error res)
@@ -413,7 +426,9 @@
((and id current-id (not (equal current-id id)))
(setf doc (document-properties doc))))
(let ((res (ensure-db ()
- (db-request (cat *db-name* "/" (if id id current-id))
+ (db-request (cat (url-encode *db-name*) "/" (url-encode (if id id current-id)))
+ :external-format-out :utf-8
+ :content-type "text/json"
:method :put :content (document-to-json doc)))))
(when (document-property :error res)
(error (if (equal "conflict" (document-property :error res))
@@ -422,12 +437,11 @@
:reason (document-property :reason res)))
res)))
-
(defun post-document (doc)
"Create a document and let the server assign an ID. A successful
areturn value includes the new document ID, in the :ID property."
(ensure-db ()
- (db-request (cat *db-name* "/")
+ (db-request (cat (url-encode *db-name*) "/")
:method :post
:content (document-to-json doc))))
@@ -443,7 +457,7 @@
should be a list of documents. Each document in the list may be in the
form of a hash table or an associative list."
(ensure-db ()
- (db-request (cat *db-name* "/_bulk_docs")
+ (db-request (cat (url-encode *db-name*) "/_bulk_docs")
:method :post
:content-type "text/javascript"
:content
@@ -458,7 +472,7 @@
not the revision, the current document will be fetched and it's
revision number will be used for the delete."
(labels ((del (id rev)
- (db-request (cat *db-name* "/" id "?rev=" rev)
+ (db-request (cat (url-encode *db-name*) "/" (url-encode id) "?rev=" rev)
:method :delete)))
(cond ((not (null document))
(delete-document :id (document-property :_id document)
@@ -476,7 +490,7 @@
end-key count update descending skip)
"Execute query using an ad-hoc view."
(ensure-db ()
- (db-request (cat *db-name* "/_temp_view")
+ (db-request (cat (url-encode *db-name*) "/_temp_view")
:method :post
:content-type "text/javascript"
:parameters (transform-params options *view-options*)
@@ -493,7 +507,7 @@
(if (not (null (cdr views))) ", ")
(mk-view-js (cdr views))))))))
(ensure-db ()
- (db-request (cat *db-name* "/_design/" id)
+ (db-request (cat (url-encode *db-name*) "/_design/" (url-encode id))
:method :put
:content
(cat "{\"language\" : \"text/javascript\","
@@ -502,7 +516,7 @@
(defun delete-view (id &key revision)
"Delete identified view document"
(ensure-db ()
- (delete-document :id (cat "_design/" id) :revision revision)))
+ (delete-document :id (cat "_design/" (url-encode id)) :revision revision)))
(defun invoke-view (id view &rest options &key key start-key start-key-docid
end-key count update descending skip)
@@ -516,6 +530,6 @@
inconsistency."
(declare (ignore key start-key start-key-docid end-key count update descending skip))
(ensure-db ()
- (db-request (cat *db-name* "/_view/" id "/" view)
+ (db-request (cat (url-encode *db-name*) "/_view/" (url-encode id) "/" (url-encode view))
:method :get
:parameters (transform-params options *view-options*))))
--- /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2007/12/09 16:03:21 1.2
+++ /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2007/12/14 23:22:58 1.3
@@ -100,7 +100,6 @@
(create-document '(("name" . "Czech Republic")
("tags" . ("country" "european"))
("motto" . "Truth prevails")
-
("demographics" . ((:population . 10230000)
;; A nested map property:
(:religion . ((:agnostic . 0.59)
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2007/12/09 16:03:21 1.2
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2007/12/14 23:22:58 1.3
@@ -330,6 +330,12 @@
(return-from test nil)))
t))))
+(addtest (clouchdb-doc-api-tests)
+ (:documentation "Test document ID encoding")
+ encode-document-id
+ (ensure (document-property :ok (create-document '((:a "test")) :id "http://google.com")))
+ (ensure-same (document-property :_id (get-document "http://google.com")) "http://google.com"))
+
;;
;; View API Tests
;;
More information about the clouchdb-cvs
mailing list