[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Mon Sep 6 22:22:50 UTC 2010
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv5302/src
Modified Files:
changelog.txt clouchdb.lisp package.lisp tests.lisp
Log Message:
Cleanup, change db-name to name, other changes in changelog.txt
--- /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2009/11/27 22:49:28 1.17
+++ /project/clouchdb/cvsroot/clouchdb/src/changelog.txt 2010/09/06 22:22:50 1.18
@@ -1,4 +1,12 @@
+0.0.14:
+ - Applied patch for basic-authorization provided by Knut Olav Bøhmer
+ - Updated ensure-db to use missing-db error message instead of re-checking for db existance
+ - Removed unused parameters from ensure-db
+ - Added 'user' and 'password' parameters to with-connection macro
+ - Fixed bug in save-attachment
+ - Export db-protocol in package.lisp
+
0.0.13:
- Applied ad-hoc-view patch from Marco
- Added basic authentication support
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/11/27 22:48:32 1.47
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2010/09/06 22:22:50 1.48
@@ -29,7 +29,7 @@
(defvar *default-db-name* "default" "Default database name")
(defvar *default-protocol* "http" "http or https")
(defvar *default-content-type* "application/octet-stream")
-
+(defvar *view-function-names* '(map reduce validate-doc-update))
(defvar *debug-requests* nil)
(defstruct (db (:constructor new-db))
@@ -297,7 +297,7 @@
(couchdb-host-url *couchdb*) "/"
(apply #'concatenate 'string rest)))
-(defmacro ensure-db ((&key (db-name nil db-name-p)) &body body)
+(defmacro ensure-db (&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
not distinguish between an error due to a missing document and a
@@ -305,11 +305,10 @@
(let ((result (gensym)))
`(let ((,result (progn , at body)))
(when (and (listp ,result)
- (equal "not_found" (document-property :|error| ,result)))
- (let ((*couchdb* (if ,db-name-p (make-db :name ,db-name) *couchdb*)))
- (if (document-property :|error| (get-db-info))
- (error 'db-does-not-exist
- :result ,result :db *couchdb* :uri (make-uri)))))
+ (equal "not_found" (document-property :|error| ,result))
+ (equal "no_db_file" (document-property :|reason|, result)))
+ (error 'db-does-not-exist
+ :result ,result :db *couchdb* :uri (make-uri)))
,result)))
(defun document-as-hash (doc)
@@ -505,12 +504,17 @@
(defun db-request (uri &rest args &key &allow-other-keys)
"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)
+ (multiple-value-bind (body status headers uri stream must-close
+ reason-phrase)
+ (apply #'drakma:http-request (make-uri uri)
+ `(, at args :basic-authorization
+ ,(when (db-user *couchdb*)
+ (list (db-user *couchdb*)
+ (db-password *couchdb*)))))
(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))
+ (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)
(values (json-to-document body) status)
(values body status reason-phrase)))))
@@ -541,16 +545,15 @@
document-fetch-fn db))
(setf *couchdb* (apply #'make-db args)))
-(defmacro with-connection ((&key db name port protocol
- host document-update-fn
- document-fetch-fn) &body body)
+(defmacro with-connection ((&rest args &key (db *couchdb*)
+ name port protocol host user password
+ document-update-fn document-fetch-fn)
+ &body body)
"Execute body in the context of the specified database connection
information.."
- `(let ((*couchdb* (make-db :db ,(or db *couchdb*)
- :name ,name :port ,port
- :protocol ,protocol :host ,host
- :document-fetch-fn ,document-fetch-fn
- :document-update-fn ,document-update-fn)))
+ (declare (ignore host port name protocol user password document-update-fn
+ document-fetch-fn db))
+ `(let ((*couchdb* (apply #'make-db (quote ,args))))
(progn , at body)))
(defun document-properties (document)
@@ -1155,7 +1158,7 @@
document. If the path ends with a file name the attachment will be
created with that name."
(let ((in (get-attachment-stream doc-or-id attachment))
- (output-path (if (> 0 (length (file-namestring path)))
+ (output-path (if (> (length (file-namestring path)) 0)
path
(merge-pathnames (pathname path)
(pathname
@@ -1232,9 +1235,9 @@
(cond ((not (eq 'defun defun))
(error 'ps-view-def-error :ps-view-def
"View definition should take the form (defun <function> (params) (....)"))
- ((not (or (eq fn-name 'map) (eq fn-name 'reduce)))
+ ((not (find fn-name *view-function-names*))
(error 'ps-view-def-error :ps-view-def
- "Valid function names are 'map' or 'reduce'"))
+ (format nil "Valid function names are ~{~s ~}" *view-function-names*)))
((and (eq fn-name 'map) (not (eq 1 (length fn-param))))
(error 'ps-view-def-error :ps-view-def
"map takes one parameter, e.g.: (defun map (doc) (... (emit ...))"))
@@ -1309,6 +1312,27 @@
:method :get
:parameters (transform-params options *view-options*))))
+(defun view-util (cmd)
+ "Compact named view"
+ (multiple-value-bind (res status)
+ (db-request (cat (db-name *couchdb*) cmd)
+ :method :post)
+ (cond ((eq 202 status)
+ res)
+ ((document-property :|error| res)
+ (error 'doc-error
+ :id cmd
+ :text (document-property :|error| res)
+ :reason (document-property :|reason| res))))))
+
+(defun view-cleanup ()
+ "Compact named view"
+ (view-util "/_view_cleanup"))
+
+(defun compact-view (view-name)
+ "Compact named view"
+ (view-util (cat "/_compact/" view-name)))
+
(defun add-ps-fns (id type &rest list-defs)
"Add lists in list-defs to document identified by id. If the
document does not exist, create it. If any list function definitions
--- /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2009/07/17 00:26:32 1.16
+++ /project/clouchdb/cvsroot/clouchdb/src/package.lisp 2010/09/06 22:22:50 1.17
@@ -56,6 +56,7 @@
:db-host
:db-name
:db-password
+ :db-protocol
:db-port
:db-user
:delete-attachment
--- /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2009/11/27 22:49:28 1.30
+++ /project/clouchdb/cvsroot/clouchdb/src/tests.lisp 2010/09/06 22:22:50 1.31
@@ -147,11 +147,24 @@
doc)))))
-
-;;
-;; DB Structure Tests
-;;
-
+(addtest (clouchdb-general-tests)
+ (:documentation "Ensure connection information is correctly carried over")
+ clouchdb-with-connection0
+ (with-connection (:name "wc-name" :port "3434" :protocol "https" :user "wc-user"
+ :password "wc-pass" :document-fetch-fn #'clouchdb::delete-db
+ :document-update-fn #'clouchdb::create-db)
+ (ensure-same (db-name *couchdb*) "wc-name")
+ (ensure-same (db-port *couchdb*) "3434")
+ (ensure-same (clouchdb::db-protocol *couchdb*) "https")
+ (ensure-same (db-user *couchdb*) "wc-user")
+ (ensure-same (db-password *couchdb*) "wc-pass")))
+
+(addtest (clouchdb-general-tests)
+ (:documentation "Ensure user can be set to nil")
+ clouchdb-with-connection1
+ (with-connection (:user "wc-user")
+ (with-connection (:user nil)
+ (ensure-same nil (db-user *couchdb*)))))
;;
;; (document-property) tests
More information about the clouchdb-cvs
mailing list