[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Sat Jul 11 23:35:57 UTC 2009
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv28824
Modified Files:
package.lisp examples.lisp clouchdb.lisp
Log Message:
(this time marking all changed files)
- Renamed *db* to *couchdb* to make it easier to import this value in other apps
- Updated copy-document and other functions to allow documents to be
specified by id or by document
- Added more test cases
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2009/07/07 19:50:20 1.13
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2009/07/11 23:35:57 1.14
@@ -27,79 +27,71 @@
(defpackage :clouchdb
(:use :cl :drakma :flexi-streams :s-base64 :parenscript)
(:export
+ :*couchdb*
:ad-hoc-view
+ :add-attachment
+ :all-docs-by-seq
+ :as-deleted-document
+ :as-field-name-string
+ :as-keyword-symbol
+ :attachment-list
+ :attachment-missing
:attachment-name
:bulk-document-update
+ :compact-db
+ :copy-document
+ :couchdb-document-properties
:create-db
:create-document
:create-ps-view
:create-temp-db
:create-temp-db-name
:create-view
+ :database
:db-already-exists
+ :db-document-fetch-fn
+ :db-document-update-fn
:db-does-not-exist
:db-existential-error
+ :db-host
+ :db-name
+ :db-password
+ :db-port
+ :db-user
+ :delete-attachment
:delete-db
:delete-document
:delete-view
:doc-error
:document-as-hash
+ :document-id
:document-missing
:document-properties
:document-property
+ :document-revision
:document-to-json
-
-
-
-
-
-
+ :encode-document
:get-all-documents
+ :get-attachment-name
+ :get-attachment-stream
:get-couchdb-info
:get-db-info
:get-document
:id-missing
:id-or-revision-conflict
+ :invalid-input
:invoke-view
+ :json-to-document
:list-dbs
+ :make-db
:post-document
:ps-view
:put-document
- :set-connection
- :with-connection
- :with-temp-db
- :*db*
- :*db*
- :*document-fetch-fn*
- :*document-update-fn*
- :add-attachment
- :all-docs-by-seq
- :as-deleted-document
- :as-field-name-string
- :as-keyword-symbol
- :attachment-list
- :attachment-missing
- :compact-db
- :couchdb-document-properties
- :database
- :db-document-fetch-fn
- :db-document-update-fn
- :db-host
- :db-name
- :db-password
- :db-port
- :db-user
- :delete-attachment
- :document-id
- :document-revision
- :encode-document
- :get-attachment-name
- :get-attachment-stream
- :invalid-input
- :json-to-document
- :make-db
:query-document
:replicate
:save-attachment
+ :set-connection
:set-document-property
- :with-attachment))
+ :with-attachment
+ :with-connection
+ :with-temp-db))
--- /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2009/04/19 22:48:32 1.10
+++ /project/clouchdb/cvsroot/clouchdb/src/examples.lisp 2009/07/11 23:35:57 1.11
@@ -29,17 +29,6 @@
(in-package :clouchdb-examples)
-;; Set the following to point to your CouchDb server. These values
-;; represent the defaults.
-
-;(defparameter *host* "localhost")
-
-;; Port for CouchDb versions prior to 7.2
-;(defparameter *port* "8888")
-;; Port CouchDb 7.2 and later
-;(defparameter *port* "5984")
-;(defparameter *scheme* "http")
-
;;
;;
;;
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/07/07 19:50:19 1.37
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/07/11 23:35:57 1.38
@@ -43,7 +43,7 @@
:name *default-db-name*
:protocol *default-protocol*))
-(defvar *db* (make-default-db) "A db struct object")
+(defvar *couchdb* (make-default-db) "A db struct object")
(defvar *text-types*
'(("text" . nil)
@@ -158,6 +158,17 @@
(declare (ignore condition))
(format stream "No ID specified"))))
+(define-condition invalid-id (doc-error)
+ ((id-value :initarg :id-value :reader id-value))
+ (:report (lambda (condition stream)
+ (format stream "Invalid ID: ~a" (id-value condition)))))
+
+(define-condition invalid-document (doc-error)
+ ((value :initarg :value :reader value))
+ (:report (lambda (condition stream)
+ (format stream "Value ~s is not a Document"
+ (value condition)))))
+
(define-condition document-missing (doc-error)
()
(:report (lambda (condition stream)
@@ -261,7 +272,7 @@
(defun make-uri (&rest rest)
"Return a URI containing protocol://host:port/ and the concatenation
of the remaining parameters."
- (concatenate 'string (couchdb-host-url *db*) "/"
+ (concatenate 'string (couchdb-host-url *couchdb*) "/"
(apply #'concatenate 'string rest)))
(defmacro ensure-db ((&key (db-name nil db-name-p)) &body body)
@@ -273,10 +284,10 @@
`(let ((,result (progn , at body)))
(when (and (listp ,result)
(equal "not_found" (document-property :|error| ,result)))
- (let ((*db* (if ,db-name-p (make-db :name ,db-name) *db*)))
+ (let ((*couchdb* (if ,db-name-p (make-db :name ,db-name) *couchdb*)))
(if (document-property :|error| (get-db-info))
(error 'db-does-not-exist
- :result ,result :db *db* :uri (make-uri)))))
+ :result ,result :db *couchdb* :uri (make-uri)))))
,result)))
(defun document-as-hash (doc)
@@ -347,8 +358,16 @@
(defun document-id (doc)
"Shortcut for getting the ID from the specified document. First
checks for :|_id| property, then :|id|"
- (or (document-property :|_id| doc)
- (document-property :|id| doc)))
+ (cond ((stringp doc)
+ doc)
+ ((or (null doc) (not (listp doc)))
+ (error 'invalid-document :value doc))
+ (t
+ (let ((id (or (document-property :|_id| doc)
+ (document-property :|id| doc))))
+ (unless id
+ (error 'invalid-document :value doc))
+ id))))
(defun document-revision (doc-or-id)
"Return the revision number for the document, identified by either
@@ -437,7 +456,7 @@
(values body status reason-phrase)))))
(defun make-db (&key host port name protocol user password
- document-fetch-fn document-update-fn (db *db*))
+ document-fetch-fn document-update-fn (db *couchdb*))
"Create, populate and return a database structure from the current
special variables and any supplied keyword parameters, the latter take
precedence over the special variables."
@@ -451,26 +470,26 @@
:document-update-fn (or document-update-fn (db-document-update-fn db))))
(defun set-connection (&key host db-name protocol port
- (db *db*) document-update-fn document-fetch-fn)
+ (db *couchdb*) document-update-fn
+ document-fetch-fn)
"Set top-level connection information. The port may be specified as
a string or number. As of CouchDb version 7.2 the default port is
5984, prior to that it was 8888."
- (setf *db* (make-db :db db :host host :name db-name
+ (setf *couchdb* (make-db :db db :host host :name db-name
:protocol protocol :port port
:document-update-fn document-update-fn
:document-fetch-fn document-fetch-fn)))
-(defmacro with-connection ((&key db-name port protocol host
+(defmacro with-connection ((&key db db-name port protocol host
document-update-fn document-fetch-fn)
- &body body)
- "Execute body in the context of the optionally specified host,
-db-name, port or protocol. Port may be a string or a number, protocol
-qis http or https. As of CouchDb version 7.2 the default port is 5984,
-prior to that it was 8888."
- `(let ((*db* (make-db :name ,db-name :port ,port
- :protocol ,protocol :host ,host
- :document-fetch-fn ,document-fetch-fn
- :document-update-fn ,document-update-fn)))
+ &body body)
+ "Execute body in the context of the specified database connection
+information.."
+ `(let ((*couchdb* (make-db :db ,db
+ :name ,db-name :port ,port
+ :protocol ,protocol :host ,host
+ :document-fetch-fn ,document-fetch-fn
+ :document-update-fn ,document-update-fn)))
(progn , at body)))
(defun document-properties (document)
@@ -485,6 +504,13 @@
(remove-if-not #'(lambda (e) (equal "_" (subseq (symbol-name (car e)) 0 1)))
document))
+(defmacro db-or-db-name (db)
+ ""
+ `(cond ((stringp ,db)
+ (make-db :name ,db))
+ ((db-p ,db) ,db)
+ (t nil)))
+
;;
;; CouchDB Database Management API
;;
@@ -494,14 +520,16 @@
host."
(db-request "_all_dbs" :method :get))
-(defun create-db (&key (db *db*) (db-name nil db-name-p) (if-exists :fail))
- "Create database. If db and db-name are unspecified, uses *db*. If
-database already exists an error condition is raised. This condition
-can be avoided by specifying :ingore for if-exists. In this case no
-error condition is generated. Specify :recreate to potentially delete
-and create a new database."
- (let ((*db* (if db-name-p (make-db :db db :name db-name) db)))
- (let ((res (db-request (cat (url-encode (db-name *db*)) "/")
+(defun create-db (&key (db *couchdb*) (if-exists :fail))
+ "Create database. The db parameter may be either a string which is
+the name of the database to create or an instance of a db
+structure. If db is unspecified, uses *couchdb*. If database already
+exists an error condition is raised. This condition can be avoided by
+specifying :ingore for if-exists. In this case no error condition is
+generated. Specify :recreate to potentially delete and create a new
+database."
+ (let ((*couchdb* (db-or-db-name db)))
+ (let ((res (db-request (cat (url-encode (db-name *couchdb*)) "/")
:method :put :content "")))
(if (equal "file_exists" (document-property :|error| res))
(ecase if-exists
@@ -514,43 +542,46 @@
(restart-case
(error 'db-already-exists
:result res
- :db *db*
- :uri (make-uri (db-name *db*)))
+ :db *couchdb*
+ :uri (make-uri (db-name *couchdb*)))
(ignore () :report "Ignore error and continue" nil))))
res))))
-(defun delete-db (&key (db *db*) (db-name nil db-name-p) if-missing)
+(defun delete-db (&key (db *couchdb*) if-missing)
"Delete database. If db and db-name are unspecified, deletes
-database named in *db*. Normally deletion of non-existent databases
+database named in *couchdb*. Normally deletion of non-existent databases
generates an 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 db)))
- (res (db-request (cat (url-encode name) "/") :method :delete)))
+ (let* ((*couchdb* (db-or-db-name db))
+ (res (db-request (cat (url-encode (db-name *couchdb*)) "/")
+ :method :delete)))
(if (and (document-property :|error| res) (not (eq :ignore if-missing)))
(restart-case
(error 'db-does-not-exist
- :result res :db db :uri (make-uri))
+ :result res :db *couchdb* :uri (make-uri))
(ignore () :report "Ignore error and continue" nil)))
res))
-(defun compact-db (&key (db *db*))
+(defun compact-db (&key (db *couchdb*))
"Start compaction on current database, or specified database if
-supplied."
- (let ((*db* db))
+supplied. The db parameter, if supplied, is either a local database
+name string or a db struct."
+ (let ((*couchdb* (db-or-db-name db)))
(ensure-db ()
- (db-request (cat (db-name *db*) "/_compact") :method :post))))
+ (db-request (cat (db-name *couchdb*) "/_compact") :method :post))))
-(defun get-couchdb-info (&key (db *db*))
+(defun get-couchdb-info (&key (db *couchdb*))
"Get information from the couchdb server."
- (let ((*db* db))
+ (let ((*couchdb* db))
(db-request nil :method :get)))
-(defun get-db-info (&key (db *db*) db-name)
+(defun get-db-info (&key (db *couchdb*))
"Get information for named database, return ((:|error|
. \"not_found\") (:|reason| . \"no_db_file\")) if database does not
- exist."
- (let ((*db* (make-db :db db :name db-name)))
- (db-request (cat (url-encode (db-name *db*)) "/")
+ exist. The db parameter, if supplied, is either a local database
+ name string or a db struct."
+ (let ((*couchdb* (db-or-db-name db)))
+ (db-request (cat (url-encode (db-name *couchdb*)) "/")
:method :get)))
(defun create-temp-db-name ()
@@ -573,7 +604,7 @@
"Execute body in context of newly created, temporary
database. Delete database before return."
(let ((result (gensym)))
- `(let* ((*db* (create-temp-db))
+ `(let* ((*couchdb* (create-temp-db))
(,result))
(unwind-protect
(setf ,result (progn , at body))
@@ -608,7 +639,7 @@
limit stale descending skip group group-level
reduce include-docs))
(ensure-db ()
- (db-request (cat (url-encode (db-name *db*)) "/_all_docs")
+ (db-request (cat (url-encode (db-name *couchdb*)) "/_all_docs")
:method (if keys :post :get)
:content-type "application/json"
:parameters (transform-params options *view-options*)
@@ -633,7 +664,9 @@
(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 *db*)) "/"
+ (let ((res (ensure-db () (db-request (cat (url-encode
+ (db-name *couchdb*))
+ "/"
(url-encode id))
:method :get
:parameters parameters))))
@@ -644,8 +677,8 @@
((and if-missing-p (not (eq if-missing :error)))
if-missing)
(t (error 'document-missing :id id))))
- (document-update-notify (db-document-fetch-fn *db*) res)))))
-
+ (document-update-notify
+ (db-document-fetch-fn *couchdb*) res)))))
(defun encode-file (file)
""
@@ -690,18 +723,20 @@
(setf doc (document-properties doc))))
(when attachments
(setf doc (cons (encode-attachments attachments) doc)))
- (let ((res (ensure-db () (db-request (cat (url-encode (db-name *db*)) "/"
+ (let ((res (ensure-db () (db-request (cat (url-encode (db-name *couchdb*)) "/"
(url-encode (if id id current-id)))
:content-type "text/javascript"
:external-format-out +utf-8+
:content-length nil
:content (document-to-json
(document-update-notify
- (db-document-update-fn *db*) doc))
+ (db-document-update-fn *couchdb*)
+ doc))
:method :put))))
(when (document-property :|error| res)
(error (if (equal "conflict" (document-property :|error| res))
- 'id-or-revision-conflict 'doc-error)
+ 'id-or-revision-conflict
+ 'doc-error)
:id (if id id current-id)
:reason (document-property :|reason| res)))
res)))
@@ -713,14 +748,15 @@
copying documents. The return value includes the document ID in
the :ID property."
(let ((res (ensure-db ()
- (db-request (cat (url-encode (db-name *db*)) "/")
+ (db-request (cat (url-encode (db-name *couchdb*)) "/")
:content-type "text/javascript"
:external-format-out +utf-8+
:content-length nil
:method :post
:content (document-to-json
(document-update-notify
- (db-document-update-fn *db*) doc))))))
+ (db-document-update-fn *couchdb*)
+ doc))))))
(when (document-property :|error| res)
(error 'doc-error :id nil :reason (document-property :|reason| res)))
res))
@@ -732,20 +768,47 @@
(put-document doc :id id :attachments attachments)
(post-document doc)))
-(defun copy-document (from-id to-id &key revision)
- "Copy one document to another document. If the destination already
-exists, and the intention is to overwrite the destination, then the
-revision parameter must be specified and must be the revision of the
-destination document."
- (let ((id (if revision (cat to-id "?rev=" revision) to-id)))
+(defun copy-document (source destination &key revision)
+ "Copy source document to destination. The source parameter may be
+ either a document ID or a document from which the ID will be
+ obtained. The destination parameter may also be a document ID or
+ document. If the destination document does not already exist it will
+ be created.
+
+ If the destination document does exist and the intention is to
+ overwrite that document, then the destination document revision must
+ be specified. If the destination parameter is a document then the
+ revision information will be taken from that document unless
+ the :revision parameter is specified. The revision parameter must be
+ the current revision of the destination document. Alternatively the
+ revision parameter may be the keyword
+ :current which will cause this function to fetch the current
+ revision number from the database."
+ (let ((rev (cond ((eq :current revision)
+ (document-revision (get-document destination)))
+ ((and (not revision) (listp destination))
+ (document-revision destination))
+ (t revision)))
+ (dest-id (document-id destination)))
(ensure-db ()
- (db-request (cat (url-encode (db-name *db*)) "/"
- (url-encode from-id))
- :content-type "text/plain"
- :external-format-out +utf-8+
- :content-length nil
- :method :copy
- :additional-headers `(("Destination" . ,id))))))
+ (let ((res (db-request (cat (url-encode (db-name *couchdb*)) "/"
+ (url-encode (document-id source)))
+ :content-type "text/plain"
+ :external-format-out +utf-8+
+ :content-length nil
+ :method :copy
+ :additional-headers
+ `(("Destination" .
+ ,(if rev
+ (cat dest-id "?rev=" rev)
+ dest-id))))))
+ (when (document-property :|error| res)
+ (error (if (equal "conflict" (document-property :|error| res))
+ 'id-or-revision-conflict
+ 'doc-error)
+ :id dest-id
+ :reason (document-property :|reason| res)))
+ res))))
(defun all-docs-by-seq (&rest options &key key keys start-key
start-key-docid end-key end-key-docid limit
@@ -757,7 +820,7 @@
limit stale descending skip group group-level
reduce include-docs))
(ensure-db ()
- (db-request (cat (url-encode (db-name *db*)) "/_all_docs_by_seq")
+ (db-request (cat (url-encode (db-name *couchdb*)) "/_all_docs_by_seq")
:method (if keys :post :get)
:content-type "application/json"
:parameters (transform-params options *view-options*)
@@ -776,7 +839,7 @@
an :|_id| value, then a document is created with a CouchDb assigned
ID. Any documents containing a (:|_deleted| . t) value will "
(ensure-db ()
- (db-request (cat (url-encode (db-name *db*)) "/_bulk_docs")
+ (db-request (cat (url-encode (db-name *couchdb*)) "/_bulk_docs")
:method :post
:content-type "text/javascript"
:external-format-out +utf-8+
@@ -801,7 +864,7 @@
(labels ((del (id rev)
(let ((res (ensure-db ()
(db-request
- (cat (url-encode (db-name *db*)) "/"
+ (cat (url-encode (db-name *couchdb*)) "/"
(url-encode id)
"?rev="
(url-encode (value-as-string rev)))
@@ -840,24 +903,30 @@
(attachment-name (car attachment)))
(t attachment)))
-(defun attachment-list (doc-or-id)
+(defun attachment-list (doc-or-id &key fetch)
"List attachments associated with document. If the document id is
specified in the first parameter then this function will fetch the
corresponding document from the server in order to get the attachment
[117 lines skipped]
More information about the clouchdb-cvs
mailing list