[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Sat Jan 19 20:15:44 UTC 2008
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv31043/src
Modified Files:
clouchdb.lisp
Log Message:
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2008/01/07 01:21:24 1.18
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2008/01/19 20:15:44 1.19
@@ -1,4 +1,4 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*-
+I;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*-
;;; Copyright (c) 2007 Peter Eddy. All rights reserved.
@@ -31,7 +31,6 @@
(defvar *protocol* "http" "http or https")
(defvar *document-update-fn* nil)
(defvar *document-fetch-fn* nil)
-(defvar *raw-json* nil)
(defvar *text-types*
'(("text" . nil)
@@ -136,7 +135,9 @@
(define-condition id-missing (doc-error)
()
- (:report (lambda (condition stream) (format stream "No ID specified"))))
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "No ID specified"))))
(define-condition document-missing (doc-error)
()
@@ -188,10 +189,10 @@
probably way too inefficient, but it seems to work."
(octets-to-string (string-to-octets string :external-format encoding)))
-(defun url-encode (string)
+(defun url-encode (string &key (external-format +utf-8+))
"URL-encode a string."
(with-output-to-string (s)
- (loop for c across (convert-encoding string +utf-8+)
+ (loop for c across (convert-encoding string external-format)
do (cond ((or (char<= #\0 c #\9)
(char<= #\a c #\z)
(char<= #\A c #\Z)
@@ -201,6 +202,22 @@
(write-string "%20" s))
(t (format s "%~2,'0x" (char-code c)))))))
+;; (defun alist-to-url-encoded-string (alist &key (external-format +utf-8+))
+;; "ALIST is supposed to be an alist of name/value pairs where both
+;; names and values are strings. This function returns a string where
+;; this list is represented as for the content type
+;; `application/x-www-form-urlencoded', i.e. the values are URL-encoded
+;; using the external format EXTERNAL-FORMAT, the pairs are joined with a
+;; #\\& character, and each name is separated from its value with a #\\=
+;; character."
+;; (with-output-to-string (out)
+;; (loop for first = t then nil
+;; for (name . value) in alist
+;; unless first do (write-char #\& out)
+;; do (format out "~A=~A"
+;; (url-encode name :external-format external-format)
+;; (url-encode value :external-format external-format)))))
+
(defun make-uri (&rest rest)
"Return a URI containing *protocol*://*host*:*port*/ and the
concatenation of the remaining parameters."
@@ -271,14 +288,9 @@
(gethash name doc))
(t (cdr (assoc name doc))))))
-(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)))
-
(defun (setf document-property) (value name doc)
- "Allows setting of document properties in place (destructively)."
+ "Allows setting of existing document properties in
+place (destructively)."
(let ((name (as-keyword-symbol name)))
(cond ((hash-table-p doc)
(setf (gethash name doc) value))
@@ -287,13 +299,43 @@
(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)))
+add it to the document, otherwise change the existing value. Does not
+destructively modify input document, so be sure to use return value."
+ (let ((doc (copy-tree doc)))
+ (if (assoc name doc)
+ (setf (document-property name doc) value)
+ (cons `(,(as-keyword-symbol name) . ,value) doc))))
+
+(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)))
(defun query-document (query doc)
+ "Return a list of all values in the document matching the query. For
+example, given the document:
+
+ ((:values (((:a . 1) (:b . 2)) ((:a . 3) (:b . 4)))))
+
+the query string '(:values :a) will return (3 1), i.e. the value of
+both :a associations.
+
+One special query input value is :* which is a 'wildcard'. With the
+document described above the query '(:values :*) will return (4 3 2
+1), or the values of all associations directly below :values. The
+query '(:* :*) on this document will also return (4 3 2 1).
+
+Another special query input value is :**, which recursively matches
+the next query input. For example, with the following document:
+
+ ((:level1 . ((:level2 . (((:level3 . 1)))))))
+
+The query '(:** :level3) will return (1), the value
+of :level3. Finally, functions can specified in the query. Functions
+are called with the portion of the document matched to the previous
+query element and can either return the document, return a different
+document or null."
(let ((res))
(labels ((q (query doc rec)
;;(format t "~%test: r=~s, query=~s doc=~s~%" rec query doc)
@@ -328,46 +370,37 @@
(q query doc nil)
res)))
-;; (defun print-ds (doc)
-;; (labels ((indent (n) (dotimes (ii n) (format t " ")))
-;; (pr (doc in)
-;; (when doc
-;; (indent in)
-;; (format t "~%kw?: ~s = ~s~%" doc (assoclp doc))
-;; (cond ((and (listp doc) (eq :* (car doc)))
-;; (format t "(:*")
-;; (pr (cdr doc) (1+ in)))
-;; ((assoclp doc)
-;; (format t "~%")
-;; (dolist (e doc)
-;; (pr e (1+ in))))
-;; ((keyword-assocp doc)
-;; (format t "(:~a " (car doc))
-;; (pr (cdr doc) in)
-;; (format t "~%"))
-;; ((keywordp doc)
-;; (format t "~s " doc))
-;; (t (format t "~s" doc))))))
-;; (pr doc 0)))
-
;;
;;
;;
-(defun db-request (uri &rest keys &key &allow-other-keys)
+(defun db-request (uri &rest args &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~% args: ~S~%" (make-uri uri) args)
(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)
+ (apply #'drakma:http-request (make-uri uri) args)
+ (declare (ignore reason-phrase stream uri headers status))
;; (format t " -> uri: ~S~%" uri)
;; (format t " -> headers: ~S~%" headers)
(cond (must-close
;; (format t "body: ~S~%" body)
- (setf *raw-json* body)
(json-to-document body))
(t nil)))))
+;; (defun cached-db-request (cache uri &rest args &key parameters &allow-other-keys)
+;; "If a cache is supplied try it first before reqesting from
+;; server. Cache result if cache is not nil."
+;; (cond (cache
+;; (let ((cache-key (if parameters (cons uri parameters) uri)))
+;; (format t "cache key: ~s~%" cache-key)
+;; (let ((cached (get-cached cache-key cache)))
+;; (cond (cached
+;; cached)
+;; (t
+;; (setf (get-cached cache-key cache) (apply #'db-request uri args)))))))
+;; (t (apply #'db-request uri args))))
+
;;
;;
;;
@@ -557,6 +590,13 @@
encoded))))
`(:|_attachments| . ,encoded))))
+;; (defun update-document-cache (url)
+;; "Called when a document has been updated on the server. Used for
+;; clearing associated cache data and firing notification functions."
+;; (when *document-cache*
+;; (format t "removing cached document: ~s~%" url)
+;; (remove-cached url *document-cache*)))
+
(defun put-document (doc &key id attachments)
"Create a new document or update and existing one. If the document
is new an ID must be specified (but see post-document). If the
@@ -578,30 +618,31 @@
(setf doc (document-properties doc))))
(when attachments
(setf doc (cons (encode-attachements attachments) doc)))
- ;;(format t "doc: ~S~%" doc))
- (let ((res (ensure-db ()
- (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
- (document-update-notify
- *document-update-fn* doc))
- :method :put))))
+ (let ((res (ensure-db () (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
+ (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)
- :id (if id id current-id)
- :reason (document-property :|reason| res)))
+ (error (if (equal "conflict" (document-property :|error| res))
+ 'id-or-revision-conflict 'doc-error)
+ :id (if id id current-id)
+ :reason (document-property :|reason| res)))
res)))
(defun post-document (doc)
- "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*) "/")
+ "Post the document to the server, creating a new document. An
+existing _id in the document will be ignored, the server will create a
+new document and assign a new ID. Therefore this is an easy method for
+copying documents. The return value includes the document ID in
+the :ID property."
+ (let* ((url (cat (url-encode *db-name*) "/"))
+ (res (ensure-db ()
+ (db-request url
:content-type "text/javascript"
:external-format-out +utf-8+
:content-length nil
@@ -617,12 +658,11 @@
ID."
(if id
(put-document doc :id id :attachments attachments)
- (post-document doc :attachments attachments)))
+ (post-document doc)))
(defun bulk-document-update (docs)
"Update multiple documents in a single request. The docs parameter
-should be a list of documents. Each document in the list may be in the
-form of a hash table or an associative list."
+should be a list of documents."
(ensure-db ()
(db-request (cat (url-encode *db-name*) "/_bulk_docs")
:method :post
@@ -635,15 +675,20 @@
" ] "))))
(defun delete-document (&key document id revision if-missing)
- "Delete a document. By default delete the current revision of the
-document. If specified, the document parameter must include the
-CouchDb special variables :_id and :_rev. If the id is speicified but
-not the revision, the current document will be fetched and it's
-revision number will be used for the delete."
+ "Delete a revision of a document. If the id parameter is provided
+but not the revision, the current document will be fetched and it's
+revision number will be used for the delete. If specified, the
+document parameter must include the CouchDb special properties :|_id|
+and :|_rev|. At most one revision of the document will be deleted."
(labels ((del (id rev)
- (db-request (cat (url-encode *db-name*) "/" (url-encode id) "?rev="
- (url-encode (value-as-string rev)))
- :method :delete)))
+ (let ((res (ensure-db ()
+ (db-request
+ (cat (url-encode *db-name*) "/" (url-encode id)
+ "?rev=" (url-encode (value-as-string rev)))
+ :method :delete))))
+ (when (document-property :|error| res)
+ (error 'doc-error) :id id :reason (document-property :|reason| res))
+ res)))
(cond ((not (null document))
(delete-document :id (document-property :|_id| document)
:revision (document-property :|_rev| document)
@@ -657,6 +702,7 @@
(when doc
(del id (document-property :|_rev| doc)))))
(t (del id revision)))))
+
;;
;; Views API
;;
More information about the clouchdb-cvs
mailing list