From peddy at common-lisp.net Mon Jan 7 01:21:24 2008 From: peddy at common-lisp.net (peddy) Date: Sun, 6 Jan 2008 20:21:24 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080107012124.55A9456245@common-lisp.net> 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 From peddy at common-lisp.net Mon Jan 7 01:23:41 2008 From: peddy at common-lisp.net (peddy) Date: Sun, 6 Jan 2008 20:23:41 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080107012341.C861956245@common-lisp.net> Update of /project/clouchdb/cvsroot/clouchdb/src In directory clnet:/tmp/cvs-serv15316/src Added Files: cache.lisp Log Message: Adding cache for real this time --- /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/07 01:23:41 NONE +++ /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/07 01:23:41 1.1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*- ;;; Copyright (c) 2007 Peter Eddy. All rights reserved. ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. (in-package :clouchdb) (proclaim '(inline cache-size rmcache)) ;; Representation of cached value (defstruct cached key value previous next) ;; The cache data structure (defstruct cache hashtable head tail (max-size 300 :type integer)) (defun new-mru-cache (&key (size 100) (rehash-size 100) (rehash-threshold 0.9) (max-size 100) (test #'eql)) "Make a new MRU cache." (make-cache :hashtable (make-hash-table :size size :test test :rehash-size rehash-size :rehash-threshold rehash-threshold) :max-size max-size)) (defun remove-element (element cache) "Remove specified element from cache linked list" (if (cached-previous element) (setf (cached-next (cached-previous element)) (cached-next element)) (setf (cache-head cache) (cached-next element))) (if (cached-next element) (setf (cached-previous (cached-next element)) (cached-previous element)) (setf (cache-tail cache) (cached-previous element)))) (defun cache-size (cache) "Return number of elements in cache." (hash-table-count (cache-hashtable cache))) (defun move-to-top (element cache) "Move specified cache element to top of cache" (unless (eq (cache-head cache) element) (remove-element element cache) (setf (cached-previous element) nil) (let ((old-head (cache-head cache))) (setf (cache-head cache) element) (setf (cached-next element) old-head) (if old-head (setf (cached-previous old-head) element) (setf (cache-tail cache) element))))) (defun set-cache-top (element cache) "Set the element at the top of the cache. Used when adding new element." (let ((head (cache-head cache))) (cond ((null head) (setf (cache-tail cache) element)) (t (setf (cached-previous head) element) (setf (cached-next element) head))) (setf (cache-head cache) element))) (defun get-cached (key cache) "Get cached value by key." (let ((element (gethash key (cache-hashtable cache)))) (when element (move-to-top element cache) (cached-value element)))) (defun rmcache (element cache) "Remove element from hashtable and linked list." (remove-element element cache) (remhash (cached-key element) (cache-hashtable cache))) (defun (setf get-cached) (value key cache) "Add new cached value or update current value associated with key. Moves cached element to top of cache list. May result in least recently used element element being removed." (let ((element (gethash key (cache-hashtable cache)))) (cond ((null element) (let ((new-element (make-cached :key key :value value))) (setf (gethash key (cache-hashtable cache)) new-element) (set-cache-top new-element cache))) (t (move-to-top element cache) (setf (cached-value element) value) (move-to-top element cache))) (when (> (cache-size cache) (cache-max-size cache)) (rmcache (cache-tail cache) cache)) cache)) (defun remove-cached (key cache) "Remove specified element from cache" (let ((element (gethash key (cache-hashtable cache)))) (when element (rmcache element cache)))) From peddy at common-lisp.net Sat Jan 12 20:44:42 2008 From: peddy at common-lisp.net (peddy) Date: Sat, 12 Jan 2008 15:44:42 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080112204442.B617281011@common-lisp.net> Update of /project/clouchdb/cvsroot/clouchdb/src In directory clnet:/tmp/cvs-serv5413 Modified Files: cache.lisp Log Message: Fixed bug in mru cache, added tests --- /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/07 01:23:41 1.1 +++ /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/12 20:44:41 1.2 @@ -24,9 +24,13 @@ (in-package :clouchdb) +;;; This is an implementation of a most recently used cache. It's +;;; primary data structures are a hashtable and a doubly linked list +;;; list. + (proclaim '(inline cache-size rmcache)) -;; Representation of cached value +;; Representation of cached value (hash table value) (defstruct cached key value previous next) ;; The cache data structure @@ -34,10 +38,8 @@ hashtable head tail (max-size 300 :type integer)) -(defun new-mru-cache (&key (size 100) - (rehash-size 100) - (rehash-threshold 0.9) - (max-size 100) +(defun make-mru-cache (&key (size 100) (rehash-size 100) + (rehash-threshold 0.9) (max-size 300) (test #'eql)) "Make a new MRU cache." (make-cache :hashtable (make-hash-table :size size @@ -59,7 +61,7 @@ "Return number of elements in cache." (hash-table-count (cache-hashtable cache))) -(defun move-to-top (element cache) +(defun move-to-head (element cache) "Move specified cache element to top of cache" (unless (eq (cache-head cache) element) (remove-element element cache) @@ -74,9 +76,11 @@ (defun set-cache-top (element cache) "Set the element at the top of the cache. Used when adding new element." + (setf (cached-previous element) nil) (let ((head (cache-head cache))) (cond ((null head) - (setf (cache-tail cache) element)) + (setf (cache-tail cache) element) + (setf (cached-next element) nil)) (t (setf (cached-previous head) element) (setf (cached-next element) head))) @@ -86,7 +90,7 @@ "Get cached value by key." (let ((element (gethash key (cache-hashtable cache)))) (when element - (move-to-top element cache) + (move-to-head element cache) (cached-value element)))) (defun rmcache (element cache) @@ -100,20 +104,73 @@ recently used element element being removed." (let ((element (gethash key (cache-hashtable cache)))) (cond ((null element) - (let ((new-element (make-cached :key key :value value))) - (setf (gethash key (cache-hashtable cache)) new-element) - (set-cache-top new-element cache))) + (set-cache-top + (setf (gethash key (cache-hashtable cache)) + (make-cached :key key :value value)) + cache)) (t - (move-to-top element cache) + (move-to-head element cache) (setf (cached-value element) value) - (move-to-top element cache))) + (move-to-head element cache))) (when (> (cache-size cache) (cache-max-size cache)) (rmcache (cache-tail cache) cache)) - cache)) + value)) (defun remove-cached (key cache) "Remove specified element from cache" (let ((element (gethash key (cache-hashtable cache)))) (when element - (rmcache element cache)))) \ No newline at end of file + (rmcache element cache)))) + +;; +;; Tests and test helper functions +;; + +(defun cached-keys (cache) + "For testing, quick way to view keys in hashtable." + (let ((keys)) + (maphash #'(lambda (k v) (push k keys)) (cache-hashtable cache)) + keys)) + +(defun linked-list-length (cache) + (labels ((lllen (ll len) + (if (null ll) + len + (lllen (cached-next ll) (1+ len))))) + (lllen (cache-head cache) 0))) + +(defun list-vals-not-in-hash (cache) + "Return items in the mru cache's linked list that are not in the cache." + (let ((res)) + (labels ((lvnic (ll) + (when ll + (format t "testing: ~s~%" (cached-key ll)) + (when (null (gethash (cached-key ll) (cache-hashtable cache))) + (format t "found uncached: ~s~%" (cached-key ll)) + (push ll res)) + (lvnic (cached-next ll))))) + (lvnic (cache-head cache))) + res)) + +(defun find-key-in-list (cache key) + (labels ((fkil (ll) + (cond ((null ll) + nil) + ((equal (cached-key ll) key) + ll) + (t (fkil (cached-next ll)))))) + (fkil (cache-head cache)))) + +(defun hash-keys-not-in-list (cache) + (let ((res)) + (maphash #'(lambda (k v) + (unless (find-key-in-list cache k) + (push k res))) + (cache-hashtable cache)))) + +(defun test-cache-consistency (cache) + (format t "Cache size: ~S, linked list length: ~S~%" + (cache-size cache) (linked-list-length cache)) + (format t "Keys not in list: ~S~%" (hash-keys-not-in-list cache)) + (format t "List values not in hash: ~S~%" (list-vals-not-in-hash cache))) From peddy at common-lisp.net Sat Jan 19 20:15:44 2008 From: peddy at common-lisp.net (peddy) Date: Sat, 19 Jan 2008 15:15:44 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080119201544.9EF3256238@common-lisp.net> 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 ;; From peddy at common-lisp.net Sat Jan 19 20:18:57 2008 From: peddy at common-lisp.net (peddy) Date: Sat, 19 Jan 2008 15:18:57 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080119201857.BCCAA56238@common-lisp.net> Update of /project/clouchdb/cvsroot/clouchdb/src In directory clnet:/tmp/cvs-serv31191/src Modified Files: tests.lisp package.lisp encoder.lisp clouchdb.asd changelog.txt cache.lisp Log Message: --- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2008/01/07 01:21:24 1.10 +++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2008/01/19 20:18:57 1.11 @@ -366,17 +366,17 @@ (addtest (clouchdb-doc-api-tests) (:documentation "Create a document with create-document") create-document-auto-id - (ensure (document-property :|ok| (create-document '((:a "test")))))) + (ensure (document-property :|ok| (create-document '((:a . "test")))))) (addtest (clouchdb-doc-api-tests) (:documentation "Create document with create-document, specify document ID") create-document-specified-id - (ensure (document-property :|ok| (create-document '((:a "test")) :id "specified")))) + (ensure (document-property :|ok| (create-document '((:a . "test")) :id "specified")))) (addtest (clouchdb-doc-api-tests) (:documentation "Create a document with a duplicate ID") create-document-specified-id-conflict - (ensure (document-property :|ok| (create-document '((:a "test")) :id "specified"))) + (ensure (document-property :|ok| (create-document '((:a . "test")) :id "specified"))) (ensure-condition 'id-or-revision-conflict (create-document '((:a "test")) :id "specified"))) --- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2008/01/07 01:21:24 1.6 +++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2008/01/19 20:18:57 1.7 @@ -25,7 +25,7 @@ (cl:in-package :cl-user) (defpackage :clouchdb - (:use :cl :drakma :flexi-streams) + (:use :cl :drakma :flexi-streams :s-base64) (:export :*scheme* :*host* :*port* --- /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2008/01/07 01:21:24 1.6 +++ /project/clouchdb/cvsroot/clouchdb/src/encoder.lisp 2008/01/19 20:18:57 1.7 @@ -127,10 +127,15 @@ ((listp d) (write-list d stream)))) +(defun document-to-json-stream (doc stream) + "Encode document to stream with special support for detecting and +handling associative lists." + (if (null doc) + (write-string "{}" stream) + (encode doc stream))) + (defun document-to-json (doc) - "Encode document with special support for detecting and handling -associative lists." + "Encode document to string with special support for detecting and +handling associative lists." (with-output-to-string (stream) - (if (null doc) - (write-string "{}" stream) - (encode doc stream)))) + (document-to-json-stream doc stream))) --- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.asd 2007/12/28 16:25:51 1.4 +++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.asd 2008/01/19 20:18:57 1.5 @@ -39,6 +39,7 @@ :version #.*clouchdb-version* :depends-on (:drakma :parenscript + :s-base64 :flexi-streams) :components ((:file "package") (:file "clouchdb") --- /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2007/12/21 19:58:32 1.6 +++ /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2008/01/19 20:18:57 1.7 @@ -1,4 +1,13 @@ +0.0.8: + + - Function set-document-property now operates non-destructively, be + sure existing code is using use function's result. + - Added function query-document to make it easier to extract the + interesting portions of complex documents. Inspired by xpath style + queries. + - Added hooks to intercept document fetching and updating/creating. + 0.0.7: - Copied and modified cl-json encoding functions to better handle conversion of lisp associative lists to json data types. --- /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/12 20:44:41 1.2 +++ /project/clouchdb/cvsroot/clouchdb/src/cache.lisp 2008/01/19 20:18:57 1.3 @@ -24,9 +24,8 @@ (in-package :clouchdb) -;;; This is an implementation of a most recently used cache. It's -;;; primary data structures are a hashtable and a doubly linked list -;;; list. +;;; This is an implementation of a most recently used (MRU) +;;; cache. Random access to cached data is through a hashtable, (proclaim '(inline cache-size rmcache)) @@ -36,20 +35,16 @@ ;; The cache data structure (defstruct cache hashtable head tail + remove-notify-fn add-notify-fn (max-size 300 :type integer)) -(defun make-mru-cache (&key (size 100) (rehash-size 100) - (rehash-threshold 0.9) (max-size 300) - (test #'eql)) - "Make a new MRU cache." - (make-cache :hashtable (make-hash-table :size size - :test test - :rehash-size rehash-size - :rehash-threshold rehash-threshold) - :max-size max-size)) +;; +;; Cache Helper Functions +;; -(defun remove-element (element cache) - "Remove specified element from cache linked list" +(defun rm-element (element cache) + "Remove specified element from cache linked list, adjust cache head +and tail if apropriate." (if (cached-previous element) (setf (cached-next (cached-previous element)) (cached-next element)) (setf (cache-head cache) (cached-next element))) @@ -57,14 +52,10 @@ (setf (cached-previous (cached-next element)) (cached-previous element)) (setf (cache-tail cache) (cached-previous element)))) -(defun cache-size (cache) - "Return number of elements in cache." - (hash-table-count (cache-hashtable cache))) - (defun move-to-head (element cache) - "Move specified cache element to top of cache" + "Move specified cache element to head of cache doubly linked list." (unless (eq (cache-head cache) element) - (remove-element element cache) + (rm-element element cache) (setf (cached-previous element) nil) (let ((old-head (cache-head cache))) (setf (cache-head cache) element) @@ -86,42 +77,87 @@ (setf (cached-next element) head))) (setf (cache-head cache) element))) -(defun get-cached (key cache) - "Get cached value by key." +(defun rm-cache (element cache) + "Remove element from hashtable and linked list, call the remove +notification method if it has been specified." + (rm-element element cache) + (remhash (cached-key element) (cache-hashtable cache)) + (when (cache-remove-notify-fn cache) + (funcall (cache-remove-notify-fn cache) + (cached-key element) (cached-value element) cache))) + +;; +;; Public API +;; + +(defun make-mru-cache (&key (size 100) (rehash-size 100) + (rehash-threshold 0.9) (max-size 300) + (test #'eql) remove-notify-fn) + "Make a new MRU cache. Arguments are the same as for +make-hash-table, except for max-size, which limits the cache to a +specific size." + (make-cache :hashtable (make-hash-table :size size + :test test + :rehash-size rehash-size + :rehash-threshold rehash-threshold) + :remove-notify-fn remove-notify-fn + :max-size max-size)) + +(defun get-cached (key cache &key (update-mru t)) + "Get cached value by key, move cached element to top of MRU list, +unless update-mru is false." (let ((element (gethash key (cache-hashtable cache)))) - (when element + (when (and element update-mru) (move-to-head element cache) (cached-value element)))) -(defun rmcache (element cache) - "Remove element from hashtable and linked list." - (remove-element element cache) - (remhash (cached-key element) (cache-hashtable cache))) +(defun cache-size (cache) + "Return the number of elements in the cache." + (hash-table-count (cache-hashtable cache))) (defun (setf get-cached) (value key cache) "Add new cached value or update current value associated with -key. Moves cached element to top of cache list. May result in least -recently used element element being removed." +key. Moves new or updated cache element to top of cache list. May +result in least recently used element element being removed." (let ((element (gethash key (cache-hashtable cache)))) (cond ((null element) (set-cache-top (setf (gethash key (cache-hashtable cache)) (make-cached :key key :value value)) - cache)) + cache) + (when (cache-add-notify-fn cache) + (funcall (cache-add-notify-fn cache) key value cache))) (t (move-to-head element cache) (setf (cached-value element) value) (move-to-head element cache))) (when (> (cache-size cache) (cache-max-size cache)) - (rmcache (cache-tail cache) cache)) + (rm-cache (cache-tail cache) cache)) value)) (defun remove-cached (key cache) "Remove specified element from cache" (let ((element (gethash key (cache-hashtable cache)))) (when element - (rmcache element cache)))) + (rm-cache element cache) + element))) + +(defun clear-cache (cache) + "Clear all data from cache." + (clrhash (cache-hashtable cache)) + (setf + (cache-head cache) nil + (cache-tail cache) nil)) + +(defun map-cache (fn cache) + "Iterates over all entries in the cache. For each entry the function +fn is called with two arguments, the cache key and the cached +value. The function can change the cached value with setf of get-cache +or it can remove the cache entry with remove-cached." + (maphash #'(lambda (k v) + (funcall fn k (cached-value v))) + (cache-hashtable cache))) ;; ;; Tests and test helper functions From peddy at common-lisp.net Sat Jan 19 20:18:57 2008 From: peddy at common-lisp.net (peddy) Date: Sat, 19 Jan 2008 15:18:57 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/public_html Message-ID: <20080119201857.F29596F2C8@common-lisp.net> Update of /project/clouchdb/cvsroot/clouchdb/public_html In directory clnet:/tmp/cvs-serv31191/public_html Modified Files: index.html Log Message: --- /project/clouchdb/cvsroot/clouchdb/public_html/index.html 2007/12/22 02:11:14 1.12 +++ /project/clouchdb/cvsroot/clouchdb/public_html/index.html 2008/01/19 20:18:57 1.13 @@ -712,9 +712,10 @@

-Create a new document, optionally specifying the document's ID. This -method simply calls (post-document) -if an ID is specified, otherwise (put-document). + Create a new document, optionally specifying the document's ID. This + method simply calls (put-document) + if an ID is specified, otherwise it calls + (post-document).

Example: @@ -801,8 +802,23 @@ post-document doc

-Create a document and let the server assign an ID. + Create a document and let the server assign an ID. An existing + :|_id| field in the document will be ignored, the server will create + a new document and assign it a new ID. This therefore is an easy way + to copy documents. The return value includes the server-assigned + document ID in the :|id| property.

+ +

+Example: +

+
+;; Create a document, let server assign an ID
+(post-document '((:field . "value")))
+
+=> ((:|ok| . T) (:|id| . "4A0FF20F6AE5168B771BC41D4557F650") (:|rev| . "16873930"))
+
+

See (create-document) (put-document)

From peddy at common-lisp.net Sat Jan 19 20:23:55 2008 From: peddy at common-lisp.net (peddy) Date: Sat, 19 Jan 2008 15:23:55 -0500 (EST) Subject: [clouchdb-cvs] CVS clouchdb/src Message-ID: <20080119202355.3FDF125123@common-lisp.net> Update of /project/clouchdb/cvsroot/clouchdb/src In directory clnet:/tmp/cvs-serv995 Modified Files: clouchdb.lisp Log Message: Removed stray character --- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2008/01/19 20:15:44 1.19 +++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2008/01/19 20:23:53 1.20 @@ -1,4 +1,4 @@ -I;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*- +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*- ;;; Copyright (c) 2007 Peter Eddy. All rights reserved.