[clouchdb-cvs] CVS clouchdb/src
peddy
peddy at common-lisp.net
Fri Nov 27 22:48:33 UTC 2009
Update of /project/clouchdb/cvsroot/clouchdb/src
In directory cl-net:/tmp/cvs-serv11039/src
Modified Files:
clouchdb.lisp
Log Message:
- Added basic authentication support
--- /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/11/22 16:41:25 1.46
+++ /project/clouchdb/cvsroot/clouchdb/src/clouchdb.lisp 2009/11/27 22:48:32 1.47
@@ -121,6 +121,16 @@
()
(:documentation "The base type of all errors signaled by clouchdb"))
+(define-condition authorization-error (clouchdb-error)
+ ((result :initarg :result :reader result)
+ (db :initarg :db :reader db)
+ (uri :initarg :uri :reader uri)
+ (text :initarg :text :reader text))
+ (:report (lambda (condition stream)
+ (format stream "Authorizion failed for URI \"~A\", reason \"~A\""
+ (uri condition)
+ (text condition)))))
+
(define-condition db-existential-error (clouchdb-error)
((text :initarg :uri :reader uri)
(db :initarg :db :reader db)
@@ -283,7 +293,8 @@
(defun make-uri (&rest rest)
"Return a URI containing protocol://host:port/ and the concatenation
of the remaining parameters."
- (concatenate 'string (couchdb-host-url *couchdb*) "/"
+ (concatenate 'string
+ (couchdb-host-url *couchdb*) "/"
(apply #'concatenate 'string rest)))
(defmacro ensure-db ((&key (db-name nil db-name-p)) &body body)
@@ -504,8 +515,11 @@
(values (json-to-document body) status)
(values body status reason-phrase)))))
-(defun make-db (&key host port name protocol user password
- document-fetch-fn document-update-fn (db *couchdb*))
+(defun make-db (&key host port name protocol
+ (user nil user-supplied-p)
+ (password nil password-supplied-p)
+ document-fetch-fn document-update-fn
+ (db *couchdb*))
"Create, populate and return a database structure from the current
special variables and any supplied keyword parameters, the latter take
precedence over the special variables."
@@ -513,21 +527,19 @@
: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))
+ :user (if user-supplied-p user (db-user db))
+ :password (if password-supplied-p 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 db-name protocol port
- (db *couchdb*) document-update-fn
- document-fetch-fn)
+(defun set-connection (&rest args &key host port name protocol user password
+ document-fetch-fn document-update-fn db)
"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."
- (setf *couchdb* (make-db :db db :host host :name db-name
- :protocol protocol :port port
- :document-update-fn document-update-fn
- :document-fetch-fn document-fetch-fn)))
+ (declare (ignore host port name protocol user password document-update-fn
+ document-fetch-fn db))
+ (setf *couchdb* (apply #'make-db args)))
(defmacro with-connection ((&key db name port protocol
host document-update-fn
@@ -560,6 +572,12 @@
((db-p ,db) ,db)
(t nil)))
+(defun make-db-auth (db)
+ "Return user name password values or nil if no user name specified
+for db"
+ (let ((user (db-user db)))
+ (if user (list user (db-password db)))))
+
;;
;; CouchDB Database Management API
;;
@@ -581,9 +599,16 @@
(let ((*couchdb* (db-or-db-name db)))
(multiple-value-bind (res status)
(db-request (cat (url-encode (db-name *couchdb*)) "/")
- :method :put :content "")
+ :method :put :content ""
+ :basic-authorization (make-db-auth *couchdb*))
(cond ((eq 201 status)
res)
+ ((equal "unauthorized" (document-property :|error| res))
+ (error 'authorization-error
+ :text (document-property :|reason| res)
+ :result res
+ :db *couchdb*
+ :uri (make-uri (db-name *couchdb*))))
((equal "file_exists" (document-property :|error| res))
(ecase if-exists
((:ignore) (list (cons :|ok| t) (cons :|ignored| t)))
@@ -595,7 +620,8 @@
:db *couchdb*
:uri (make-uri (db-name *couchdb*)))
(ignore () :report "Ignore error and continue" nil)))))
- ((equal "illegal_database_name" (document-property :|reason| res))
+ ((or (equal "illegal_database_name" (document-property :|reason| res))
+ (equal "illegal_database_name" (document-property :|error| res)))
(error 'illegal-database-name
:result res
:db *couchdb*
@@ -606,15 +632,25 @@
database named in *couchdb*. Normally deletion of non-existent databases
generates an error condition, but this can be avoided by
specifying :ignore in the if-missing parameter."
- (let* ((*couchdb* (db-or-db-name db))
- (res (db-request (cat (url-encode (db-name *couchdb*)) "/")
- :method :delete)))
- (if (and (document-property :|error| res) (not (eq :ignore if-missing)))
- (restart-case
- (error 'db-does-not-exist
- :result res :db *couchdb* :uri (make-uri))
- (ignore () :report "Ignore error and continue" nil)))
- res))
+ (let* ((*couchdb* (db-or-db-name db)))
+ (multiple-value-bind (res status)
+ (db-request (cat (url-encode (db-name *couchdb*)) "/")
+ :method :delete
+ :basic-authorization (make-db-auth *couchdb*))
+ (cond ((eq 200 status)
+ res)
+ ((equal "unauthorized" (document-property :|error| res))
+ (error 'authorization-error
+ :text (document-property :|reason| res)
+ :result res
+ :db *couchdb*
+ :uri (make-uri (db-name *couchdb*))))
+ ((and (document-property :|error| res) (not (eq :ignore if-missing)))
+ (restart-case
+ (error 'db-does-not-exist
+ :result res :db *couchdb* :uri (make-uri))
+ (ignore () :report "Ignore error and continue" nil))))
+ res)))
(defun compact-db (&key (db *couchdb*))
"Start compaction on current database, or specified database if
@@ -674,12 +710,49 @@
(ensure-db ()
(db-request "_replicate"
:method :post
+ :basic-authorization (make-db-auth *couchdb*)
:content-type "application/json"
:content
(cat "{\"source\":\"" (make-db-identifier source) "\","
"\"target\":\"" (make-db-identifier target) "\"}"))))
;;
+;; _config API
+;;
+
+;; (defun get-config (key)
+;; ""
+;; (multiple-value-bind (res status)
+;; (db-request (cat "_config/" key) :method :get
+;; :basic-authorization (make-db-auth *couchdb*))
+;; (cond ((eq 200 status)
+;; res)
+;; ((equal "unauthorized" (document-property :|error| res))
+;; (error 'authorization-error
+;; :text (document-property :|reason| res)
+;; :result res
+;; :db *couchdb*
+;; :uri (make-uri (db-name *couchdb*))))
+;; (t res))))
+
+
+;; (defun put-config (key value)
+;; ""
+;; (multiple-value-bind (res status)
+;; (db-request (cat "_config/" key) :method :put
+;; :content value
+;; :basic-authorization (make-db-auth *couchdb*))
+;; (cond ((eq 200 status)
+;; res)
+;; ((equal "unauthorized" (document-property :|error| res))
+;; (error 'authorization-error
+;; :text (document-property :|reason| res)
+;; :result res
+;; :db *couchdb*
+;; :uri (make-uri (db-name *couchdb*))))
+;; (t res))))
+
+;;
;; CouchDB Document Management API
;;
@@ -935,6 +1008,10 @@
(url-encode id)
"?rev="
(url-encode (value-as-string rev)))
+ ;; Authorization here is for delete-view,
+ ;; it's not required for normal document
+ ;; deletes
+ :basic-authorization (make-db-auth *couchdb*)
:method :delete))))
(when (document-property :|error| res)
(error 'doc-error :id id
@@ -1138,6 +1215,7 @@
(url-encode id))
:method :put
:external-format-out +utf-8+
+ :basic-authorization (make-db-auth *couchdb*)
:content-type "application/json"
:content-length nil
:content
More information about the clouchdb-cvs
mailing list