[clouchdb-cvs] CVS clouchdb/src

peddy peddy at common-lisp.net
Mon Jul 6 22:24:45 UTC 2009


Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv8485

Modified Files:
	changelog.txt clouchdb.lisp package.lisp tests.lisp 
Log Message:
Lots of updates, including storing of db info in structure, support for attachments and replication.


--- /project/clouchdb/cvsroot/clouchdb/src/changelog.txt	2008/06/28 22:55:07	1.9
+++ /project/clouchdb/cvsroot/clouchdb/src/changelog.txt	2009/07/06 22:24:45	1.10
@@ -1,4 +1,36 @@
 
+0.0.11:
+
+  - Switched to using a structure to hold the database connection
+    information that was previously contained in special
+    variables. The structure is itself now a single special variable
+    called *db*
+
+  - Added support for stand-alone attachements
+
+  - Added get-couchdb-info for getting CouchDb server information,
+    previously this was available via get-db-info when no DB was
+    specified.
+
+  - Added database compaction support with the function compact-db
+
+  - Added replication support with the replicate function
+
+  - Added all-docs-by-seq function
+
+  - Changed delete-document to take a required parameter which is
+    either the document ID or the document, removed the keyword
+    parameters :id and :document.
+
+  - Updated various functions to use recently added CouchDb
+    parameters:
+
+    bulk-document-update:
+     - added all-or-nothing parameter
+
+        
+
+
 0.0.10:
 
   - Views now use the new map/reduce/emit style JavaScript definitions
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2009/06/27 13:05:23	1.35
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp	2009/07/06 22:24:45	1.36
@@ -24,12 +24,26 @@
 
 (in-package :clouchdb)
 
-(defvar *host* "localhost" "CouchDb server host name")
-(defvar *port* "5984" "The IANA assigned CouchDb port")
-(defvar *db-name* "default" "Default database name")
-(defvar *protocol* "http" "http or https")
-(defvar *document-update-fn* nil)
-(defvar *document-fetch-fn* nil)
+(defvar *default-host* "localhost" "CouchDb server host name")
+(defvar *default-port* "5984" "The IANA assigned CouchDb port")
+(defvar *default-db-name* "default" "Default database name")
+(defvar *default-protocol* "http" "http or https")
+(defvar *default-content-type* "application/octet-stream")
+
+(defvar *debug-requests* nil)
+
+(defstruct db
+  host port name protocol 
+  user password
+  document-fetch-fn document-update-fn)
+
+(defun make-default-db ()
+  (make-db :host *default-host*
+           :port *default-port*
+           :name *default-db-name*
+           :protocol *default-protocol*))
+
+(defvar *db* (make-default-db) "A db struct object")
 
 (defvar *text-types* 
   '(("text" . nil) 
@@ -106,21 +120,21 @@
 
 (define-condition db-existential-error (error)
   ((text :initarg :uri :reader uri)
-   (db-name :initarg :db-name :reader db-name)
+   (db :initarg :db :reader db)
    (result :initarg :result :reader result)))
 
 (define-condition db-does-not-exist (db-existential-error) 
   ()
   (:report (lambda (condition stream)
 	     (format stream "Database \"~A\" at \"~A\" does not exist" 
-		     (db-name condition)
+		     (db-name (db condition))
 		     (uri condition)))))
 
 (define-condition db-already-exists (db-existential-error) 
   ()
   (:report (lambda (condition stream)
 	     (format stream "Database \"~A\" at \"~A\" already exists" 
-		     (db-name condition)
+		     (db-name (db condition))
 		     (uri condition)))))
 
 (define-condition doc-error (error) 
@@ -151,6 +165,17 @@
 		     (id condition))))
   (:documentation "Error raised when no document matching ID is found"))
 
+(define-condition attachment-missing (doc-error)
+  ((attachment-name :initarg :attachment-name :reader att-name)
+   (attachments :initarg :attachments :reader attachments))
+  (:report (lambda (condition stream)
+             (format stream "No attachment named \"~A\" found for
+             document ID \"~A\", known attachments: ~s"
+                     (att-name condition)
+                     (id condition)
+                     (attachments condition))))
+  (:documentation "Error raised when specified attachment is not found"))
+
 (define-condition ps-view-def-error (error)
   ((ps-view-def :initarg :ps-view-def :reader ps-view-def))
   (:report (lambda (condition stream)
@@ -158,6 +183,13 @@
                      (ps-view-def condition))))
   (:documentation "Error raised for invalid ps-view definition"))
 
+(define-condition invalid-input (error)
+  ((input :initarg :input :reader input)
+   (description :initarg :description :reader description))
+  (:report (lambda (condition stream)
+	     (format stream "Invalid input \"~A\", Description=~S"
+		     (input condition) (description condition)))))
+
 ;;
 ;; Unexported utility functions
 ;;
@@ -212,17 +244,26 @@
                      (write-string "%20" s))
                    (t (format s "%~2,'0x" (char-code c)))))))
 
+(defun couchdb-host-url (db)
+  (cat (db-protocol db) "://" (db-host db) ":" (db-port db)))
+
+(defun couchdb-database-url (db)
+  (cat (couchdb-host-url db) "/" (db-name db)))
+
+(defun make-db-identifier (input)
+  "Make a database identifier from either a string or db structure."
+  (cond ((stringp input) input)
+        ((db-p input) (couchdb-database-url input))
+        (t (error 'invalid-input 
+                  :input input
+                  :description "Database must be a string or a database structure"))))
+
 (defun make-uri (&rest rest)
-  "Return a URI containing *protocol*://*host*:*port*/ and the
-concatenation of the remaining parameters."
-  (concatenate 'string *protocol* "://" *host* ":" *port* "/"
+  "Return a URI containing protocol://host:port/ and the concatenation
+of the remaining parameters."
+  (concatenate 'string (couchdb-host-url *db*) "/"
 	       (apply #'concatenate 'string rest)))
 
-(defun keyword-to-special (key)
-  "Convert a keyword symbol to a special symbol. For example,
-  convert :db-name to *db-name*"
-  (intern (cat "*" (string-upcase (symbol-name key)) "*")))
-
 (defmacro ensure-db ((&key (db-name nil db-name-p)) &body body)
   "Wrap request in code to check for errors due to non-existant data
 bases. This is necessary because in a document operation, CouchDb does
@@ -230,12 +271,12 @@
 missing database."
   (let ((result (gensym)))
     `(let ((,result (progn , at body)))
-       (when (equal "not_found" (document-property :|error| ,result))
-	 (let ((dbn (if ,db-name-p ,db-name *db-name*)))
-	   (if (document-property :|error|  (get-db-info :db-name dbn))
+       (when (and (listp ,result) 
+                  (equal "not_found" (document-property :|error| ,result)))
+	 (let ((*db* (if ,db-name-p (db-from-env :name ,db-name) *db*)))
+	   (if (document-property :|error| (get-db-info))
 	       (error 'db-does-not-exist
-		      :result ,result :db-name dbn
-		      :uri (make-uri dbn)))))
+		      :result ,result :db *db* :uri (make-uri)))))
        ,result)))
 
 (defun document-as-hash (doc)
@@ -309,6 +350,15 @@
   (or (document-property :|_id| doc)
       (document-property :|id| doc)))
 
+(defun document-revision (doc-or-id)
+  "Return the revision number for the document, identified by either
+the document ID, the actual document, or the result of an add or
+update that returns the revision as :|rev|"
+  (cond ((stringp doc-or-id)
+         (document-revision (get-document doc-or-id)))
+        (t (or (document-property :|_rev| doc-or-id)
+               (document-property :|rev| doc-or-id)))))
+
 (defun query-document (query doc)
   "Return a list of all values in the document matching the query. For
 example, given the document:
@@ -373,125 +423,134 @@
 ;;
 
 (defun db-request (uri &rest args &key &allow-other-keys)
-  "Used by all Couchdb APIs to make the actual REST request."
+  "Used by most Clouchdb APIs to make the actual REST request."
   (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) args)
-      (declare (ignore reason-phrase stream uri headers status))
-      (cond (must-close
-             (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))))
+      ;;(declare (ignore must-close reason-phrase stream uri headers status))
+      (when *debug-requests*
+        (format t "uri: ~s~%args: ~s~%must-close:~s~%reason-phrase:
+        ~s~%status: ~s~%headers: ~s~%stream:~s~%body:~s~%" uri args
+        must-close reason-phrase status headers stream body))
+      (if (stringp body) 
+          (json-to-document body)
+          (values body status reason-phrase)))))
+
+(defun db-from-env (&key host port name protocol user password
+                    document-fetch-fn document-update-fn (db *db*))
+  "Create, populate and return a database structure from the current
+special variables and any supplied keyword parameters, the latter take
+precendence over the special vars."
+  (make-db :host (or host (db-host db) *default-host*)
+           :port (or port (db-port db) *default-port*)
+           :name (or name (db-name db) *default-db-name*)
+           :protocol (or protocol (db-protocol db) *default-protocol*)
+           :user (or user (db-user db))
+           :password (or password (db-password db))
+           :document-fetch-fn (or document-fetch-fn (db-document-fetch-fn db))
+           :document-update-fn (or document-update-fn (db-document-update-fn db))))
 
-;;
-;;
-;;
-
-(defun set-connection (&key (host nil host-p) (db-name nil db-name-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))
+(defun set-connection (&key host db-name protocol port
+                       (db *db*) document-update-fn document-fetch-fn)
   "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."
-  (when host-p (setf *host* host))
-  (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))
+  (setf *db* (db-from-env :db db :host host :name db-name 
+                          :protocol protocol :port port
+                          :document-update-fn document-update-fn
+                          :document-fetch-fn document-fetch-fn)))
 
-(defmacro with-connection ((&rest args &key db-name port protocol host
-                                  document-update-fn document-fetch-fn)
+(defmacro with-connection ((&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,
+qis 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 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))
+  `(let ((*db* (db-from-env :name ,db-name :port ,port 
+                            :protocol ,protocol :host ,host 
+                            :document-fetch-fn ,document-fetch-fn
+                            :document-update-fn ,document-update-fn)))
+     (progn , at body)))
 
 (defun document-properties (document)
   "Return the document properties, filtering out any couchdb reserved
 properties (properties that start with an underscore)."
-  (remove-if #'(lambda (e) (equal "_" (subseq (symbol-name (car e)) 0 1))) document))
+  (remove-if #'(lambda (e) (equal "_" (subseq (symbol-name (car e)) 0 1))) 
+             document))
 
 (defun couchdb-document-properties (document)
-  "Return only CouchDb specific document properties (opposite of document-properties)."
-  (remove-if-not #'(lambda (e) (equal "_" (subseq (symbol-name (car e)) 0 1))) document))
+  "Return only CouchDb specific document properties (opposite of
+document-properties)."
+  (remove-if-not #'(lambda (e) (equal "_" (subseq (symbol-name (car e)) 0 1))) 
+                 document))
 
 ;;
 ;; CouchDB Database Management API
 ;;
 
 (defun list-dbs ()
-  "Return a list of all databases for the current host and port."
+  "Return a list of all databases managed by the current CouchDb
+host."
   (db-request "_all_dbs" :method :get))
 
-(defun create-db (&key (db-name nil db-name-p) (if-exists :fail))
-  "Create database. If db-name is unspecified, uses *db-name*. If
+(defun create-db (&key (db *db*) (db-name nil db-name-p) (if-exists :fail))
+  "Create database. If db and db-name are unspecified, uses *db*. If
 database already exists an error condition is raised. This condition
 can be avoided by specifying :ingore for if-exists. In this case no
 error condition is generated. Specify :recreate to potentially delete
 and create a new database."
-  (let* ((name (if db-name-p db-name *db-name*))
-	 (res (db-request (cat (url-encode name) "/") 
-                          :method :put :content "")))
-    (if (equal "file_exists" (document-property :|error| res))
-      (ecase if-exists
-	((:ignore) (list (cons :|ok| t) (cons :|ignored| t)))
-	((:recreate) 
-	 (delete-db :db-name name) 
-	 (create-db :db-name name))
-	((:fail)
-	 (restart-case
-	     (error 'db-already-exists
-		    :result res :db-name name
-		    :uri (make-uri name))
-	   (ignore () :report "Ignore error and continue" nil))))
-      res)))
-
-(defun delete-db (&key (db-name nil db-name-p) if-missing)
-  "Delete database. If db-name is unspecified, deletes database named
-in *db-name*. Normally deletion of non-existent databases generates an
-error condition, but this can be avoided by specifying :ignore in the
-if-missing parameter."
-  (let* ((name (if db-name-p db-name *db-name*))
+  (let ((*db* (if db-name-p (db-from-env :db db :name db-name) db)))
+    (let ((res (db-request (cat (url-encode (db-name *db*)) "/")
+                           :method :put :content "")))
+      (if (equal "file_exists" (document-property :|error| res))
+          (ecase if-exists
+            ((:ignore) 
+             (list (cons :|ok| t) (cons :|ignored| t)))
+            ((:recreate) 
+             (delete-db)
+             (create-db))
+            ((:fail)
+             (restart-case
+                 (error 'db-already-exists
+                        :result res 
+                        :db *db*
+                        :uri (make-uri (db-name *db*)))
+               (ignore () :report "Ignore error and continue" nil))))
+          res))))
+
+(defun delete-db (&key (db *db*) (db-name nil db-name-p) if-missing)
+  "Delete database. If db and db-name are unspecified, deletes
+database named in *db*. Normally deletion of non-existent databases
+generates an error condition, but this can be avoided by
+specifying :ignore in the if-missing parameter."
+  (let* ((name (if db-name-p db-name (db-name db)))
 	 (res (db-request (cat (url-encode name) "/") :method :delete)))
     (if (and (document-property :|error| res) (not (eq :ignore if-missing)))
 	(restart-case 
 	    (error 'db-does-not-exist
-		   :result res :db-name name
-		   :uri (make-uri name))
+		   :result res :db db :uri (make-uri))
 	  (ignore () :report "Ignore error and continue" nil)))
     res))
 
-(defun compact-db (&key (db-name *db-name*))
+(defun compact-db (&key (db *db*))
   "Start compaction on current database, or specified database if
 supplied."
-  (ensure-db (:db-name db-name)
-    (db-request (cat db-name "/_compact") :method :post)))
+  (let ((*db* db))
+    (ensure-db ()
+      (db-request (cat (db-name *db*) "/_compact") :method :post))))
 
-(defun get-db-info (&key (db-name nil db-name-p))
-  "Get information for named database, or couchdb server if no
-database specified."
-  (let ((dbn (if db-name-p db-name *db-name*)))
-    (db-request (if dbn (cat (url-encode dbn) "/"))
+(defun get-couchdb-info (&key (db *db*))
+  "Get information from the couchdb server."
+  (let ((*db* db))
+    (db-request nil :method :get)))
+
+(defun get-db-info (&key (db *db*) db-name)
+  "Get information for named database, return ((:|error|
+  . \"not_found\") (:|reason| . \"no_db_file\")) if database does not
+  exist."
+  (let ((*db* (db-from-env :db db :name db-name)))
+    (db-request (cat (url-encode (db-name *db*)) "/")
                 :method :get)))
 
 (defun create-temp-db-name ()
@@ -503,40 +562,60 @@
 
 (defun create-temp-db (&key (db-name-creator #'create-temp-db-name))
   "Create a temporary database."
-  (let ((db-name (funcall db-name-creator)))
-    (let ((res (create-db :db-name db-name)))
+  (let ((db (db-from-env :name (funcall db-name-creator))))
+    (let ((res (create-db :db db)))
       (if (document-property :|error| res)
 	  (error (format t "Error ~S creating database: ~A"
-		       (document-property :|error| res) db-name))))
-    db-name))
+		       (document-property :|error| res) (db-name db)))))
+    db))
 
 (defmacro with-temp-db (&body body)
   "Execute body in context of newly created, temporary
 database. Delete database before return."
-  (let ((temp-db-name (gensym))
-	(result (gensym)))
-    `(let* ((,temp-db-name (create-temp-db))
-	    (,result (with-connection (:db-name ,temp-db-name)
-		      , at body)))
-       (delete-db ,temp-db-name)
+  (let ((result (gensym)))

[429 lines skipped]
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp	2009/04/19 22:48:32	1.11
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp	2009/07/06 22:24:45	1.12
@@ -26,51 +26,81 @@
 
 (defpackage :clouchdb
   (:use :cl :drakma :flexi-streams :s-base64 :parenscript)
-  (:export :*scheme*
-	   :*host*
-	   :*port*
-	   :*db-name*
-           :*document-update-fn*
-           :*document-fetch-fn*
-           :as-keyword-symbol
-           :as-field-name-string
-	   :db-existential-error
-	   :db-does-not-exist
-	   :db-already-exists
-	   :doc-error
-	   :id-or-revision-conflict
-	   :id-missing
-	   :document-missing
-	   :document-to-json
-           :json-to-document
-	   :document-as-hash
-           :encode-document
-	   :set-connection
-	   :with-connection
-	   :document-properties
-	   :document-property
-           :couchdb-document-properties
-           :document-id
-           :query-document
-           :set-document-property
-	   :list-dbs
-	   :create-db
-	   :delete-db
-	   :create-temp-db
-	   :create-temp-db-name
-	   :with-temp-db
-	   :get-db-info
-	   :get-all-documents
-	   :get-document
-	   :put-document
-	   :post-document
-	   :create-document
-	   :bulk-document-update
-           :as-deleted-document
-	   :delete-document
-	   :create-view
-	   :create-ps-view
-	   :ps-view
-	   :delete-view
-	   :invoke-view
-	   :ad-hoc-view))
+  (:export 
+   :ad-hoc-view
+   :attachment-name
+   :bulk-document-update
+   :create-db
+   :create-document
+   :create-ps-view
+   :create-temp-db
+   :create-temp-db-name
+   :create-view
+   :db-already-exists
+   :db-does-not-exist
+   :db-existential-error
+   :delete-db
+   :delete-document
+   :delete-view
+   :doc-error
+   :document-as-hash
+   :document-missing
+   :document-properties
+   :document-property
+   :document-to-json
+
+
+
+
+
+
+   :get-all-documents
+   :get-couchdb-info
+   :get-db-info
+   :get-document
+   :id-missing
+   :id-or-revision-conflict
+   :invoke-view
+   :list-dbs
+   :post-document
+   :ps-view
+   :put-document
+   :set-connection
+   :with-connection
+   :with-temp-db
+   :*db*
+   :*db*
+   :*document-fetch-fn*
+   :*document-update-fn*
+   :add-attachment
+   :all-docs-by-seq
+   :as-deleted-document
+   :as-field-name-string
+   :as-keyword-symbol
+   :attachment-list
+   :attachment-missing
+   :compact-db
+   :couchdb-document-properties
+   :database
+   :db-document-fetch-fn
+   :db-document-update-fn
+   :db-from-env
+   :db-host
+   :db-name
+   :db-password
+   :db-port
+   :db-user
+   :delete-attachment
+   :document-id
+   :document-revision
+   :encode-document
+   :get-attachment-name
+   :get-attachment-stream
+   :invalid-input
+   :json-to-document
+   :make-db
+   :query-document
+   :replicate
+   :save-attachment
+   :set-document-property
+   :with-attachment))
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2009/06/06 19:15:18	1.17
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp	2009/07/06 22:24:45	1.18
@@ -1,5 +1,4 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB-EXAMPLES; Base: 10 -*-
-
 ;;; Copyright (c) 2007 Peter Eddy. All rights reserved.
 
 ;;; Permission is hereby granted, free of charge, to any person
@@ -127,19 +126,11 @@
 ;; CouchDb server information.
 ;;
 
-(deftestsuite clouchdb-tests () 
-  ()
-  (:dynamic-variables 
-   (*db-name* nil) 
-;   (*host* "localhost") 
-   (*port* "5984") 
-   (*protocol* "http")))
-
 ;;
 ;; General tests that do not require a db connection
 ;;
 
-(deftestsuite clouchdb-general-tests (clouchdb-tests) () ())
+(deftestsuite clouchdb-general-tests () ())
 
 (addtest (clouchdb-general-tests)
   (:documentation "Ensure document-property gets correct value from document")
@@ -157,8 +148,10 @@
   general-tests-case-encoded
   (ensure-same "lowercase" (as-field-name-string (as-keyword-symbol "lowercase")))
   (ensure-same "MixedCase" (as-field-name-string (as-keyword-symbol "MixedCase")))
-  (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"))))
+  (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")
@@ -279,29 +272,32 @@
 ;; databases or the server.
 ;;
 
-(deftestsuite clouchdb-db-admin-tests (clouchdb-tests) () ())
+(deftestsuite clouchdb-db-admin-tests () ())
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "Look for the welcome message and version info from server")
   generic-server-info-query
-  (ensure-same "Welcome" (document-property :|couchdb| (get-db-info)))
-  (ensure (document-property :|version| (get-db-info))))
+  (ensure-same "Welcome" (document-property :|couchdb| (get-couchdb-info)))
+  (ensure (document-property :|version| (get-couchdb-info))))
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "Ensure get-db-info reports non-existant databases")
   db-non-existance-test
-  (ensure (setf *db-name* (create-temp-db-name)))
-  (ensure-same "not_found" (document-property :|error| (get-db-info)))
-  (ensure-same "no_db_file" (document-property :|reason|  (get-db-info))))
+  (let ((*db* (db-from-env :name (create-temp-db-name))))
+    (ensure-same "not_found" (document-property :|error| 
+                                                (get-db-info)))
+    (ensure-same "no_db_file" (document-property :|reason|  (get-db-info)))))
 
 (addtest (clouchdb-db-admin-tests)
-  (:documentation "Create a database and ensure it's there, ensure it's deleted too")
+  (:documentation "Create a database and ensure it gets created")
   db-creation-test
-  (ensure (setf *db-name* (create-temp-db)))
-  (ensure-same (document-property :|db_name| (get-db-info)) *db-name*)
-  (ensure-same 0 (document-property :|doc_count| (get-db-info)))
-  (ensure-same 0 (document-property :|update_seq| (get-db-info)))
-  (ensure (document-property :|ok| (delete-db))))
+  (with-temp-db
+    (ensure-same (document-property :|db_name| (get-db-info))
+                 (db-name *db*))
+    (ensure-same (document-property :|db_name| (get-db-info :db *db*))
+                 (db-name *db*))
+    (ensure-same 0 (document-property :|doc_count| (get-db-info :db *db*)))
+    (ensure-same 0 (document-property :|update_seq| (get-db-info :db *db*)))))
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "Make sure deleting a nonexistant db generates an error")
@@ -319,49 +315,55 @@
 (addtest (clouchdb-db-admin-tests)
   (:documentation "Creating a db that already exists is an error")
   db-create-existant-db
-  (ensure (setf *db-name* (create-temp-db)))
-  (ensure-condition 'db-already-exists (create-db))
-  (ensure (delete-db)))
+  (ensure-condition 'db-already-exists 
+    (with-temp-db 
+      (create-db))))
+
+(addtest (clouchdb-db-admin-tests)
+  (:documentation "Creating a db that already exists is an error")
+  db-create-existant-db-name
+  (ensure-condition 'db-already-exists 
+    (with-temp-db
+      (db-name (create-db :db-name (db-name *db*))))))
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "Ignore the duplicate db create error")
   db-ignore-create-existant-db
-  (ensure (setf *db-name* (create-temp-db)))
-  (ensure (document-property :|ok| (create-db :if-exists :ignore)))
-  (ensure (delete-db)))
+  (ensure (document-property :|ok|
+                             (with-temp-db
+                               (create-db :if-exists :ignore)))))
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "recreate option for create-db on existing db")
   db-recreate-db
-  (ensure (setf *db-name* (create-temp-db)))
-  (ensure (document-property :|ok| (create-db :if-exists :recreate)))
-  (ensure (delete-db)))
+  (ensure (document-property :|ok|
+                             (with-temp-db
+                               (create-db :if-exists :recreate)))))
 
 (addtest (clouchdb-db-admin-tests)
   (:documentation "recreate option for create-db on non-existant db")
   db-recreate-nonexistant-db
-  (ensure (document-property :|ok| (create-db :if-exists :recreate)))
-  (ensure (delete-db)))
-
-;;
-;; Test suite that runs each test in a newly created database and
-;; deletes that database after each test.
-;;
-
-(deftestsuite clouchdb-freshdb-tests (clouchdb-tests) ()
-  (:setup (set-connection :db-name (create-temp-db)))
-  (:teardown (delete-db)))
+  (with-temp-db
+    (ensure (document-property :|ok| (create-db :if-exists :recreate)))))
 
 ;;
 ;; Document API Tests
 ;;
 
-(deftestsuite clouchdb-doc-api-tests (clouchdb-freshdb-tests) () ())
+(deftestsuite clouchdb-doc-api-tests ()
+  ()
+  (:dynamic-variables
+   (*db* (db-from-env :db *db*)))
+  (:setup
+   (set-connection :db (create-temp-db)))
+  (:teardown 
+   (delete-db)))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Ensures the temporary db for these tests is succesfully created.")
   empty-test
-  (ensure-same (document-property :|db_name| (get-db-info)) *db-name*))
+  (ensure-same (document-property :|db_name| (get-db-info)) 
+               (db-name *db*)))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Create a document with create-document")
@@ -371,12 +373,16 @@
 (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")
+  (:documentation 
+   "Create a document with a duplicate ID and ensure revision conflict")
   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")))
 
@@ -414,7 +420,7 @@
   (:documentation "Delete a document by ID")
   delete-document-by-id
   (ensure (document-property :|ok| (create-document '((:a "test")) :id "specified")))
-  (ensure (document-property :|ok| (delete-document :id "specified"))))
+  (ensure (document-property :|ok| (delete-document "specified"))))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Delete a document by ID and revision")
@@ -422,8 +428,10 @@
   (ensure (progn
 	    (create-document '((:a . "document")) :id "specified")
 	    (let ((doc (get-document "specified")))
-	      (document-property :|ok| (delete-document :id (document-property :|_id| doc)
-						      :revision (document-property :|_rev| doc)))))))
+	      (document-property :|ok| 
+                                 (delete-document (document-id doc)
+                                                  :revision 
+                                                  (document-revision doc)))))))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Delete a document by document")
@@ -431,12 +439,12 @@
   (ensure (progn
 	    (create-document '((:a . "document")) :id "polly")
 	    (document-property :|ok| 
-			       (delete-document :document (get-document "polly"))))))
+			       (delete-document (get-document "polly"))))))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Delete a non-existant document")
   delete-document-bad-id
-  (ensure-condition 'document-missing (delete-document :id "specified")))
+  (ensure-condition 'document-missing (delete-document "specified")))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Add a bunch of documents and ensure they get created.")
@@ -491,8 +499,11 @@
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Test document ID encoding")
   encode-document-id
-  (ensure (document-property :|ok| (create-document '((:a "test")) :id "http://google.com")))
-  (ensure-same (document-property :|_id| (get-document "http://google.com")) "http://google.com"))
+  (ensure (document-property :|ok| 
+                             (create-document '((:a "test")) 
+                                              :id "http://google.com")))
+  (ensure-same (document-id (get-document "http://google.com")) 
+               "http://google.com"))
 
 (addtest (clouchdb-doc-api-tests)
   (:documentation "Test encoding and decoding of utf-8 document IDs")
@@ -544,12 +555,119 @@
                                 (equal (cdr e)
                                        (document-property (car e) doc)))
                             doc)))))))
+
+;;
+;; Attachments 
+;;
+
+(addtest (clouchdb-doc-api-tests)
+  (:documentation "Test adding attachment 0")
+  add-attachment-0
+  (ensure (document-property :|ok|
+                             (add-attachment "doc" 
+                                             (pathname "tests.lisp"))))
+  (let ((attachments (attachment-list "doc")))
+    (ensure-same 1 (length attachments))
+    (ensure-same "tests.lisp" (attachment-name (car attachments)))))
+
+(addtest (clouchdb-doc-api-tests)
+  (:documentation "Test adding attachment using name other than file name")
+  add-attachment-1
+  (ensure (document-property :|ok|
+                             (add-attachment "doc" 
+                                             (pathname "tests.lisp")
+                                             :name "something.lisp")))
+  (let ((attachments (attachment-list "doc")))
+    (ensure-same 1 (length attachments))
+    (ensure-same "something.lisp" (attachment-name (car attachments)))))
+
+(addtest (clouchdb-doc-api-tests)
+  (:documentation "Test adding multiple attachments")
+  add-attachment-2
+  (ensure (document-property :|ok|
+                             (add-attachment "doc" 
+                                             (pathname "tests.lisp")
+                                             :name "something.lisp")))
+  (ensure (document-property :|ok|
+                             (add-attachment "doc" 
+                                             (pathname "tests.lisp")
+                                             :name "something.else")))
+  (let ((attachments (attachment-list "doc")))
+    (ensure-same 2 (length attachments))
+    (ensure-same "something.lisp" (attachment-name (car attachments)))))
+
+;; 
+;; Replication Tests.
+;;
+
+(deftestsuite clouchdb-replication-tests () 
+  ()
+  (:dynamic-variables
+   (*db* (db-from-env)))
+  (:setup
+   (progn
+     (set-connection :db (create-temp-db))
+     (create-test-documents *people* :id-field :name)))
+  (:teardown 
+   (progn 
+     (delete-db)
+     (set-connection :db-name "default"))))
+
+(addtest (clouchdb-replication-tests)
+  (:documentation "test local replication of current db to new db using string identifier")
+  db-replicate-local-1
+  (let ((db *db*))
+    (with-temp-db
+      (let ((target *db*)
+            (*db* db))
+        (ensure (document-property :|ok| (replicate target)))))))
+
+(addtest (clouchdb-replication-tests)
+  (:documentation "test local replication of current db to new db using string identifiers")
+  db-replicate-local-2
+  (ensure (document-property :|ok| 
+                             (let ((source *db*))
+                               (with-temp-db
+                                 (let ((target *db*))
+                                   (replicate (db-name target) 
+                                              :source (db-name source))))))))
+
+(addtest (clouchdb-replication-tests)
+  (:documentation 
+   "test local and remote replication of current db to new db using db and string identifiers")
+  db-replicate-mixed-1
+  (ensure (document-property :|ok| 
+                             (let ((source *db*))
+                               (with-temp-db
+                                 (let ((target *db*))
+                                   (replicate target
+                                              :source (db-name source))))))))
+
+(addtest (clouchdb-replication-tests)
+  (:documentation 
+   "test remote API replication of current db to new db using database identifiers")
+  db-replicate-dbs
+  (ensure (document-property :|ok| 
+                             (let ((source *db*))
+                               (with-temp-db
+                                 (let ((target *db*))
+                                   (replicate target :source source)))))))
+
 ;;
 ;; View API Tests
 ;;
 
-(deftestsuite clouchdb-view-tests (clouchdb-freshdb-tests) ()
-  (:setup (create-test-documents *people* :id-field :name)))
+(deftestsuite clouchdb-view-tests () 
+  ()
+  (:dynamic-variables
+   (*db* (db-from-env :db *db*)))
+  (:setup
+   (progn
+     (set-connection :db (create-temp-db))
+     (create-test-documents *people* :id-field :name)))
+  (:teardown 
+   (progn 
+     (delete-db))))
 
 (addtest (clouchdb-view-tests)
   (:documentation "Create an ad-hoc view and verify the returned count")
@@ -697,13 +815,14 @@
                                       :start-key '("boston" "c")
                                       :end-key '("boston" "d"))))))
 
-;;
-;;
-;;
+
+
+
 
 (defun run-all-tests ()
   (dolist (suite '(clouchdb-general-tests
                    clouchdb-db-admin-tests
 		   clouchdb-doc-api-tests
-		   clouchdb-view-tests))
+		   clouchdb-view-tests
+                   clouchdb-replication-tests))
     (format t "~S~%" (run-tests :suite suite))))





More information about the clouchdb-cvs mailing list