[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Sat Dec 29 20:03:42 UTC 2007
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv7071/src
Modified Files:
package.lisp clouchdb.lisp
Log Message:
Added hooks for document put/fetch actions
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2007/12/28 16:25:51 1.4
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2007/12/29 20:03:42 1.5
@@ -30,6 +30,8 @@
:*host*
:*port*
:*db-name*
+ :*document-update-fn*
+ :*document-fetch-fn*
:as-keyword-symbol
:as-field-name-string
:db-existential-error
@@ -45,6 +47,7 @@
:with-connection
:document-properties
:document-property
+ :set-document-property
:list-dbs
:create-db
:delete-db
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/28 16:25:51 1.15
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/29 20:03:42 1.16
@@ -29,6 +29,8 @@
"As of version 7.2, the IANA assigned CouchDb port (was 8888)")
(defvar *db-name* "default" "Default database name")
(defvar *protocol* "http" "http or https")
+(defvar *document-update-fn* nil)
+(defvar *document-fetch-fn* nil)
(defvar *text-types*
'(("text" . nil)
@@ -39,7 +41,7 @@
(defparameter *temp-db-counter* 0 "Used in the creation of temporary databases")
(defmacro define-constant (name value &optional doc)
- "A version of DEFCONSTANT for, cough, /strict/ CL implementations."
+ "A version of DEFCONSTANT for /strict/ CL implementations."
;; See <http://www.sbcl.org/manual/Defining-Constants.html>
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when doc (list doc))))
@@ -47,6 +49,9 @@
(define-constant +utf-8+ (make-external-format :utf-8 :eol-style :lf)
"Default external format for document content.")
+(defun document-update-notify (fn doc)
+ (if fn (funcall fn doc) doc))
+
;;
;; URL Parameter helpers
;;
@@ -275,7 +280,15 @@
(cond ((hash-table-p doc)
(setf (gethash name doc) value))
(t (rplacd (assoc name doc) value)))
- value))
+ doc))
+
+(defun set-document-property (doc name value)
+ "Set a property of a document. If the named property does not exist,
+create it otherwise modify the existing value. May or may not
+destructively modify document, so be sure to use return value."
+ (if (assoc name doc)
+ (setf (document-property name doc) value)
+ (cons `(,(as-keyword-symbol name) . ,value) doc)))
(defun db-request (uri &rest keys &key &allow-other-keys)
"Used by all Couchdb APIs to make the actual REST request."
@@ -295,7 +308,9 @@
;;
(defun set-connection (&key (host nil host-p) (db-name nil db-name-p)
- (protocol nil protocol-p) (port nil port-p))
+ (protocol nil protocol-p) (port nil port-p)
+ (document-update-fn nil document-update-fn-p)
+ (document-fetch-fn nil document-fetch-fn-p))
"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."
@@ -303,15 +318,18 @@
(when db-name-p (setf *db-name* db-name))
(when port-p (setf *port* (value-as-string port)))
(when protocol-p (setf *protocol* protocol))
+ (when document-update-fn-p (setf *document-update-fn* document-update-fn))
+ (when document-fetch-fn-p (setf *document-fetch-fn* document-fetch-fn))
(values))
-(defmacro with-connection ((&rest args &key db-name port protocol host)
+(defmacro with-connection ((&rest args &key 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
is http or https. As of CouchDb version 7.2 the default port is 5984,
prior to that it was 8888."
- (declare (ignore db-name port protocol host))
+ (declare (ignore db-name port protocol host document-update-fn document-fetch-fn))
`(let (,@(loop for var on args
by #'cddr collect (list (keyword-to-special (car var)) (second var))))
, at body))
@@ -449,7 +467,7 @@
((and if-missing-p (not (eq if-missing :error)))
if-missing)
(t (error 'document-missing :id id))))
- res))))
+ (document-update-notify *document-fetch-fn* res)))))
(defun put-document (doc &key id)
"Create a new document or update and existing one. If the document
@@ -465,19 +483,21 @@
;; If an ID was specified and that ID does not match the
;; :_id property of the current document, strip the document
;; of all special (CouchDb managed) properties, since these
- ;; are specific to the current document. In this case, the
- ;; presence of the ID parameter means 'create a new document
- ;; with the same contents as the old one'.
+ ;; are specific to the current document. The presence of the
+ ;; ID parameter in this situation means 'create a new
+ ;; document with the same contents as the old one'.
((and id current-id (not (equal current-id id)))
(setf doc (document-properties doc))))
(let ((res (ensure-db ()
- (db-request (cat (url-encode *db-name*) "/"
+ (db-request (cat (url-encode *db-name*) "/"
(url-encode (if id id current-id)))
:content-type "text/javascript"
:external-format-out +utf-8+
:content-length nil
- :content (document-to-json doc)
- :method :put))))
+ :content (document-to-json
+ (document-update-notify
+ *document-update-fn* doc))
+ :method :put))))
(when (document-property :|error| res)
(error (if (equal "conflict" (document-property :|error| res))
'id-or-revision-conflict 'doc-error)
@@ -486,14 +506,16 @@
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."
+ "Put the potentially modified document back on the server or, if the
+document contains no ID, create a document and let the server assign
+one. The return value includes the document ID in the :ID property."
(let ((res (ensure-db ()
(db-request (cat (url-encode *db-name*) "/")
:content-type "text/javascript"
:external-format-out +utf-8+
:content-length nil
- :content (document-to-json doc)
+ :content (document-to-json
+ (document-update-notify *document-update-fn* doc))
:method :post))))
(when (document-property :|error| res)
(error 'doc-error) :id nil :reason (document-property :|reason| res))
More information about the clouchdb-cvs
mailing list