[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Fri Sep 10 23:38:00 UTC 2010
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv3844
Modified Files:
changelog.txt clouchdb.lisp package.lisp
Log Message:
Added initial implementation of (changes)
--- /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2010/09/06 22:22:50 1.18
+++ /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2010/09/10 23:38:00 1.19
@@ -6,6 +6,10 @@
- Added 'user' and 'password' parameters to with-connection macro
- Fixed bug in save-attachment
- Export db-protocol in package.lisp
+ - Added create-target parmaeter to replicate
+ - Removed references to create-view in doc
+ - Added duplicate error handling to create-view
+ - Added changes function (incomplete)
0.0.13:
- Applied ad-hoc-view patch from Marco
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2010/09/06 22:22:50 1.48
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2010/09/10 23:38:00 1.49
@@ -50,8 +50,6 @@
(nil . "xml"))
"Defined to instruct Drakma to treat json responses as text")
-(defparameter *temp-db-counter* 0 "Used in the creation of temporary databases")
-
(defmacro define-constant (name value &optional doc)
"A version of DEFCONSTANT for /strict/ CL implementations."
;; See <http://www.sbcl.org/manual/Defining-Constants.html>
@@ -78,6 +76,14 @@
"Return \"false\" if value is nil, otherwise nil"
(unless value "false"))
+(defparameter *changes-options*
+ '((:feed . ((:name . "feed") (:fn . keyword-to-http-param)))
+ (:since . ((:name . "since") (:fn . value-as-string)))
+ (:style . ((:name . "style") (:fn . keyword-to-http-param)))
+ (:heartbeat . ((:name . "heartbeat") (:fn . value-as-string)))
+ (:filter . ((:name . "filter") (:fn . identity))))
+ "Parameters for the changes function.")
+
(defparameter *view-options*
`((:key . ((:name . "key") (:fn . document-to-json)))
(:start-key . ((:name . "startkey") (:fn . document-to-json)))
@@ -166,6 +172,13 @@
(reason condition)
(id condition)))))
+(define-condition invalid-design-doc (doc-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Reason \"~A\", URI: \"~A\""
+ (reason condition)
+ (text condition)))))
+
(define-condition id-or-revision-conflict (doc-error)
()
(:report (lambda (condition stream)
@@ -347,6 +360,18 @@
(symbol-name value))
(t value)))
+(defun keyword-to-http-param (keyword-symbol)
+ "Convert a keword symbol that may contain hyphen characters to a
+lower case string with any hyphens replaced by underscores:
+':all-the-best' -> 'all_the_best'."
+ (substitute #\_ #\-
+ (string-downcase
+ (cond ((keywordp keyword-symbol)
+ (as-field-name-string keyword-symbol))
+ ((stringp keyword-symbol)
+ keyword-symbol)
+ (t keyword-symbol)))))
+
(defun document-property (name doc)
"Get the value associated with the document property or nil if there
is no associated value. Note that name may be either a keyword symbol,
@@ -704,12 +729,45 @@
(delete-db))
,result)))
-(defun replicate (target &key (source *couchdb*))
+(defun changes (&rest options &key (db *couchdb*) feed since style
+ heartbeat filter fn)
+ "Return the document change activity. The :feed keyword parameter
+value indicates how to poll for changes. Valid values for this
+parameter include :longpoll to block waiting for a single change
+response or :continuous to poll for changes indefinately.
+
+The :style keyword parameter should either be :main-only (the default)
+or :all-docs for more revision information."
+ (declare (ignore since style heartbeat))
+ (let ((*couchdb* (db-or-db-name db)))
+ (ensure-db ()
+ (multiple-value-bind (res status)
+ (db-request (cat (url-encode (db-name *couchdb*)) "/_changes")
+ :parameters (transform-params options *changes-options*)
+ :want-stream feed :method :get)
+ (cond ((not (equal status 200))
+ (let ((rdoc (if (stringp res) (json-to-document res) res)))
+ (cond ((equal "invalid design doc" (document-property :|reason| rdoc))
+ (error 'invalid-design-doc
+ :text res :id filter
+ :uri (make-uri (db-name *couchdb*) "/" filter)
+ :reason (document-property :|reason| rdoc))))))
+ ((and fn (streamp res))
+ (loop for line = (read-line res nil :eof)
+ while (and line
+ (not (equal line :eof))
+ (funcall fn (json-to-document line)))
+ finally (close res)))
+ ((not fn)
+ res))))))
+
+(defun replicate (target &key (source *couchdb*) (create-target nil))
"Replicate current database to target, or source to target if source
is specified. Source and target database values must either be strings
or database structures. Use strings to specify simple local database
names, use database structures to specify either local or remote
-databases."
+databases. If true, create-target will cause the replication target to
+be created automatically, as of CouchDb version 0.11."
(ensure-db ()
(db-request "_replicate"
:method :post
@@ -717,7 +775,8 @@
:content-type "application/json"
:content
(cat "{\"source\":\"" (make-db-identifier source) "\","
- "\"target\":\"" (make-db-identifier target) "\"}"))))
+ "\"target\":\"" (make-db-identifier target) "\","
+ (if create-target "\"create_target\":true") "}"))))
;;
;; _config API
@@ -776,7 +835,7 @@
limit stale descending skip group group-level
reduce include-docs))
(ensure-db ()
- (db-request (cat (url-encode (db-name *couchdb*)) "/_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*)
@@ -1212,18 +1271,24 @@
(defun create-view (id view &key (language "javascript"))
"Create one or more views in the specified view document ID."
- (ensure-db ()
- (db-request (cat (url-encode (db-name *couchdb*))
- "/_design/"
- (url-encode id))
- :method :put
- :external-format-out +utf-8+
- :basic-authorization (make-db-auth *couchdb*)
- :content-type "application/json"
- :content-length nil
- :content
- (cat "{\"language\" : \"" language "\","
- "\"views\" : {" view "}}"))))
+ (let ((res (ensure-db ()
+ (db-request (cat (url-encode (db-name *couchdb*))
+ "/_design/"
+ (url-encode id))
+ :method :put
+ :external-format-out +utf-8+
+ :basic-authorization (make-db-auth *couchdb*)
+ :content-type "application/json"
+ :content-length nil
+ :content
+ (cat "{\"language\" : \"" language "\","
+ "\"views\" : {" view "}}")))))
+ (when (document-property :|error| res)
+ (error (if (equal "conflict" (document-property :|error| res))
+ 'id-or-revision-conflict
+ 'doc-error)
+ :id id :reason (document-property :|reason| res)))
+ res))
(defun create-ps-view (id &rest view-defs)
"Create one or more views in the specified view document ID."
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2010/09/06 22:22:50 1.17
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2010/09/10 23:38:00 1.18
@@ -38,6 +38,7 @@
:attachment-missing
:attachment-name
:bulk-document-update
+ :changes
:compact-db
:copy-document
:couchdb-document-properties
More information about the clouchdb-cvs
mailing list