[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Mon Jan 7 01:21:24 UTC 2008
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv14714/src
Modified Files:
tests.lisp package.lisp encoder.lisp decoder.lisp
clouchdb.lisp
Log Message:
Added initial MRU cache implementation
Added initial query-document implementation
Added lame implementation of file attachement encoding
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2007/12/29 21:20:28 1.9
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2008/01/07 01:21:24 1.10
@@ -49,6 +49,37 @@
(:city . "san francisco")
(:friends . ("jean" "marie" "marc")))))
+(defparameter *document0*
+ '((:|total_rows| . 2)
+ (:|offset| . 0)
+ (:|rows|
+ ((:|id| . "id1")
+ (:|key| . "key1")
+ (:|value|
+ (:|_id| . "id1a")
+ (:INTEGER . 0)
+ (:NAME . "name1")
+ (:LIST . ("one" "two" "nine"))
+ (:ACL
+ (:READ "reader1" "reader2")
+ (:WRITE "writer1" "writer2")
+ (:DELETE "deleter1")
+ (:GRANT "granter1")
+ (:REVOKE "revoker1"))))
+ ((:|id| . "id2")
+ (:|key| . "key2")
+ (:|value|
+ (:|_id| . "id2a")
+ (:INTEGER . 1)
+ (:LIST . (a b c))
+ (:NAME . "name2")
+ (:ACL
+ (:READ "reader1" "reader3")
+ (:WRITE "writer1" "writer3")
+ (:DELETE "deleter1")
+ (:GRANT "granter2")
+ (:REVOKE "revoker1")))))))
+
;;
;; Test helper functions
;;
@@ -129,6 +160,118 @@
(ensure-same "Mixed-Case-Hyphen" (as-field-name-string (as-keyword-symbol "Mixed-Case-Hyphen")))
(ensure-same "UPPER-CASE" (as-field-name-string (as-keyword-symbol "UPPER-CASE"))))
+(addtest (clouchdb-general-tests)
+ (:documentation "test keyword-assocp for positive match")
+ general-tests-keword-assocp-positivie
+ (ensure (clouchdb::keyword-assocp '(:key . "value")))
+ (ensure (clouchdb::keyword-assocp '(:key . 3)))
+ (ensure (clouchdb::keyword-assocp '(:key . 'value)))
+ (ensure (clouchdb::keyword-assocp '(:key . (1 2 3))))
+ (ensure (clouchdb::keyword-assocp '(:key . ((1 2 3)))))
+ (ensure (clouchdb::keyword-assocp '(:key . ((:a . "aye") (:b . "bee"))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "test keyword-assocp for positive match")
+ general-tests-keword-assocp-negative
+ (ensure-null (clouchdb::keyword-assocp '()))
+ (ensure-null (clouchdb::keyword-assocp '(3 4)))
+ (ensure-null (clouchdb::keyword-assocp '(abe lincolin))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "test assoclp function for positive match")
+ general-tests-assoclp-positive
+ (ensure (clouchdb::assoclp '((:a . b) (:c . "dee"))))
+ (ensure (clouchdb::assoclp '((:a (1 2 3)))))
+ (ensure (clouchdb::assoclp '((:a . nil) (:b . "froth")))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "test assoclp function for negative")
+ general-tests-assoclp-negative
+ (ensure-null (clouchdb::assoclp '()))
+ (ensure-null (clouchdb::assoclp '(:a . 3)))
+ (ensure-null (clouchdb::assoclp '(:a (1 2 3))))
+ (ensure-null (clouchdb::assoclp '(:a (:b . "sea"))))
+ (ensure-null (clouchdb::assoclp '(:a ((:b . "sea") (:d . "e")))))
+ (ensure-null (clouchdb::assoclp '((:aye :bee :sea))))
+ (ensure-null (clouchdb::assoclp '((:aye :bee (:a . 3) (:b . "froth"))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "*document0* query tests ")
+ general-tests-document0-query
+ (ensure-same 2 (car (query-document '(:|total_rows|) *document0*)))
+ (ensure-same 2 (length (car (query-document '(:|rows|) *document0*))))
+ (ensure-same 2 (length (query-document '(:|rows| :|value|) *document0*)))
+ (ensure (progn
+ (let ((res (query-document '(:|rows| :|value| :|_id|) *document0*)))
+ (and (find "id2a" res :test #'equal)
+ (find "id1a" res :test #'equal)
+ (eql 2 (length res))))))
+ (ensure-same 2 (length (query-document '(:|rows| :|value| :acl) *document0*)))
+ (ensure (progn
+ (let ((res (query-document '(:|rows| :|value| :acl :read) *document0*)))
+ (and (eql 2 (length res))
+ (find "reader1" (car res) :test #'equal)
+ (find "reader3" (car res) :test #'equal)
+ (find "reader1" (second res) :test #'equal)
+ (find "reader2" (second res) :test #'equal))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "*document0* query wildcard tests ")
+ general-tests-document0-query-wildcard-top
+ (ensure-same 2 (car (query-document '(:|total_rows|) *document0*)))
+ (ensure-same 2 (length (car (query-document '(:|rows|) *document0*))))
+ (ensure-same 2 (length (query-document '(:|rows| :|value|) *document0*)))
+ (ensure (progn
+ (let ((res (query-document '(:** :|_id|) *document0*)))
+ (and (find "id2a" res :test #'equal)
+ (find "id1a" res :test #'equal)
+ (eql 2 (length res))))))
+ (ensure-same 2 (length (query-document '(:** :acl) *document0*)))
+ (ensure (progn
+ (let ((res (query-document '(:** :read) *document0*)))
+ (and (eql 2 (length res))
+ (find "reader1" (car res) :test #'equal)
+ (find "reader3" (car res) :test #'equal)
+ (find "reader1" (second res) :test #'equal)
+ (find "reader2" (second res) :test #'equal)))))
+ (ensure (progn
+ (let ((res (query-document '(:|rows| :** :read) *document0*)))
+ (and (eql 2 (length res))
+ (find "reader1" (car res) :test #'equal)
+ (find "reader3" (car res) :test #'equal)
+ (find "reader1" (second res) :test #'equal)
+ (find "reader2" (second res) :test #'equal))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "*document0* query wildcard tests ")
+ general-tests-document0-query-wildcard-middle
+ (ensure (progn
+ (let ((res (query-document '(:|rows| :** :|_id|) *document0*)))
+ (and (find "id2a" res :test #'equal)
+ (find "id1a" res :test #'equal)
+ (eql 2 (length res))))))
+ (ensure-same 2 (length (query-document '(:|rows| :** :acl) *document0*)))
+ (ensure (progn
+ (let ((res (query-document '(:|rows| :** :read) *document0*)))
+ (and (eql 2 (length res))
+ (find "reader1" (car res) :test #'equal)
+ (find "reader3" (car res) :test #'equal)
+ (find "reader1" (second res) :test #'equal)
+ (find "reader2" (second res) :test #'equal))))))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "*people* query tests")
+ general-tests-people-query
+ (ensure (progn
+ (let ((res (query-document '(:name) *people*)))
+ (and (eql 6 (length res))
+ (find "richard" res :test #'equal)
+ (find "michelle" res :test #'equal)
+ (find "laurie" res :test #'equal)
+ (find "jean" res :test #'equal)
+ (find "marc" res :test #'equal)
+ (find "peter" res :test #'equal))))))
+
;;
;; Db Administration Tests
;;
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2007/12/29 20:03:42 1.5
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2008/01/07 01:21:24 1.6
@@ -42,11 +42,15 @@
:id-missing
:document-missing
:document-to-json
+ :json-to-document
:document-as-hash
+ :encode-document
:set-connection
:with-connection
:document-properties
:document-property
+ :document-id
+ :query-document
:set-document-property
:list-dbs
:create-db
--- /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2007/12/28 16:25:51 1.5
+++ /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2008/01/07 01:21:24 1.6
@@ -56,9 +56,7 @@
(defun write-json-string (s stream)
(write-char #\" stream)
- (if (stringp s)
- (write-json-chars s stream)
- (encode-json s stream))
+ (write-json-chars s stream)
(write-char #\" stream))
(defun write-json-number (nr stream)
@@ -86,13 +84,12 @@
(and (listp list)
(not (listp (cdr list)))))
(test (list)
- (cond ((null list)
+ (cond ((or (null list) (not (listp list)))
nil)
((keyword-assocp (car list))
(car list))
((improperlistp (car list))
- (car list))
- ((test (cdr list))))))
+ (car list)))))
(and (listp e) (test e))))
(defun write-alist (d stream)
@@ -130,7 +127,7 @@
((listp d)
(write-list d stream))))
-(defun encode-document (doc)
+(defun document-to-json (doc)
"Encode document with special support for detecting and handling
associative lists."
(with-output-to-string (stream)
--- /project/clouchdb/cvsroot/clouchdb/src/decoder.lisp 2007/12/28 16:30:08 1.1
+++ /project/clouchdb/cvsroot/clouchdb/src/decoder.lisp 2008/01/07 01:21:24 1.2
@@ -70,7 +70,7 @@
(defun lisp-special-char-to-json(lisp-char)
(car (rassoc lisp-char *json-lisp-escaped-chars*)))
-(defun decode-json-from-string (json-string)
+(defun json-to-document (json-string)
(with-input-from-string (stream json-string)
(decode-json stream)))
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2007/12/29 21:20:28 1.17
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2008/01/07 01:21:24 1.18
@@ -31,6 +31,7 @@
(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)
@@ -225,12 +226,6 @@
:uri (make-uri dbn)))))
,result)))
-(defun document-to-json (doc)
- "Convert document data, the top-level of wich is either an
- associative list or hashtable, to json data"
- (encode-document doc))
-
-
(defun document-as-hash (doc)
"Convert a document to a hashtable if it isn't one already. Document
should be in the form of an associative list."
@@ -276,6 +271,12 @@
(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)."
(let ((name (as-keyword-symbol name)))
@@ -292,6 +293,67 @@
(setf (document-property name doc) value)
(cons `(,(as-keyword-symbol name) . ,value) doc)))
+(defun query-document (query doc)
+ (let ((res))
+ (labels ((q (query doc rec)
+ ;;(format t "~%test: r=~s, query=~s doc=~s~%" rec query doc)
+ (cond ((null doc)
+ nil)
+ ((null query)
+ (push doc res))
+ ((eq :** (car query))
+ (q (cdr query) doc t))
+ ((and (listp query) (eq :** (car query)))
+;; (format t "action: :**~%")
+ (q (cdr query) doc t))
+ ((assoclp doc)
+;; (format t "action: assoclp doc=~s ~%" doc)
+ (dolist (e doc)
+ (q query e rec)))
+ ((functionp (car query))
+;; (format t "action: functionp~%")
+ (q (cdr query) (funcall (car query) doc) rec))
+ ((keyword-assocp doc)
+;; (format t "action: keyword-assocp doc=~S~%" doc)
+ (cond ((or (eq (car query) (car doc)) (eq :* (car query)))
+;; (format t "action: keyword asscoc=t~%" doc)
+ (q (cdr query) (cdr doc) nil))
+ ((and rec (listp (cdr doc)))
+ (q query (cdr doc) t))))
+ ((listp doc)
+;; (format t "action: listp~%")
+ (dolist (e doc)
+ (q query e rec)))
+ (t nil))))
+ (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)
"Used by all Couchdb APIs to make the actual REST request."
;;(format t "uri: ~S~% keys: ~S~%" (make-uri uri) keys)
@@ -302,7 +364,8 @@
;; (format t " -> headers: ~S~%" headers)
(cond (must-close
;; (format t "body: ~S~%" body)
- (decode-json-from-string body))
+ (setf *raw-json* body)
+ (json-to-document body))
(t nil)))))
;;
@@ -471,7 +534,30 @@
(t (error 'document-missing :id id))))
(document-update-notify *document-fetch-fn* res)))))
-(defun put-document (doc &key id)
+
+(defun encode-file (file)
+ ""
+ (with-output-to-string (out)
+ (with-open-file (in file)
+ (let ((data (make-array (file-length in) :element-type '(unsigned-byte 8))))
+ (with-open-file (stream file :element-type '(unsigned-byte 8))
+ (read-sequence data stream)
+ (s-base64:encode-base64-bytes data out nil))))))
+
+(defun encode-attachements (attachments)
+ (let ((encoded))
+ (when attachments
+ (dolist (a attachments)
+ (format t "file name: ~S~%" (car a))
+ (let ((e (encode-file (car a))))
+ (when e
+ (push `(,(as-keyword-symbol (second a)) .
+ ((:|type| . "base64")
+ (:|data| . ,e)))
+ encoded))))
+ `(:|_attachments| . ,encoded))))
+
+(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
document has been fetched from the server (and still has its :_id
@@ -490,6 +576,9 @@
;; document with the same contents as the old one'.
((and id current-id (not (equal current-id id)))
(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)))
@@ -506,7 +595,7 @@
: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
@@ -523,12 +612,12 @@
(error 'doc-error) :id nil :reason (document-property :|reason| res))
res))
-(defun create-document (doc &key id)
+(defun create-document (doc &key id attachments)
"Create a new document, optionally specifying the new document
ID."
(if id
- (put-document doc :id id)
- (post-document doc)))
+ (put-document doc :id id :attachments attachments)
+ (post-document doc :attachments attachments)))
(defun bulk-document-update (docs)
"Update multiple documents in a single request. The docs parameter
More information about the clouchdb-cvs
mailing list