/src/core/database.lisp

  1(in-package :chillax.core)
  2
  3;;;
  4;;; Database errors
  5;;;
  6(define-condition database-error (couchdb-error)
  7  ((uri :initarg :uri :reader database-error-uri)))
  8
  9(define-condition db-not-found (database-error)
 10  ()
 11  (:report (lambda (condition stream)
 12             (format stream "Database ~A not found." (database-error-uri condition)))))
 13
 14(define-condition db-already-exists (database-error)
 15  ()
 16  (:report (lambda (condition stream)
 17             (format stream "Database ~A already exists." (database-error-uri condition)))))
 18
 19;;;
 20;;; Basic database API
 21;;;
 22
 23;; Database protocol
 24(defgeneric database-server (database)
 25  (:documentation "Returns the server object with which DATABASE is associated."))
 26(defgeneric database-name (database)
 27  (:documentation
 28   "Returns the URL-encoded name of the database, a string. Note that CouchDB accepts certain
 29   characters in database names -only- if they are URL-encoded (such as #\/). It is up to individual
 30   implementations of DATABASE-NAME to implement this encoding."))
 31
 32;; Database functions
 33(defun print-database (db stream)
 34  "Objects implementing the database protocol may use this function in their PRINT-OBJECT method."
 35  (print-unreadable-object (db stream :type t :identity t)
 36    (format stream "~A" (db-uri db))))
 37
 38(defun db-request (db uri &rest all-keys)
 39  "Sends a CouchDB request to DB."
 40  (apply #'couch-request (database-server db) (strcat (database-name db) "/" uri) all-keys))
 41
 42(defmacro handle-request ((result-var db uri &rest db-request-keys &key &allow-other-keys)
 43                          &body expected-responses)
 44  "Provides a nice interface to the relatively manual, low-level status-code checking that Chillax
 45uses to understand CouchDB's responses. The format for EXPECTED-RESPONSES is the same as the CASE
 46macro: The keys should be either keywords, or lists o keywords (not evaluated), which correspond to
 47translated HTTP status code names. See +status-codes+ for all the currently-recognized keywords."
 48  (let ((status-code (gensym "STATUS-CODE-")))
 49    `(multiple-value-bind (,result-var ,status-code)
 50         (db-request ,db ,uri ,@db-request-keys)
 51       (case ,status-code
 52         ,@expected-responses
 53         (:bad-request (error "Bad request: ~A" ,result-var))
 54         (otherwise (error 'unexpected-response :status-code ,status-code :response ,result-var))))))
 55
 56(defun db-info (db)
 57  "Fetches info about a given database from the CouchDB server."
 58  (handle-request (response db "")
 59    (:ok response)
 60    (:internal-server-error (error "Illegal database name: ~A" (database-name db)))
 61    (:not-found (error 'db-not-found :uri (db-uri db)))))
 62
 63(defun db-connect (server name)
 64  "Confirms that a particular CouchDB database exists. If so, returns a new database object that can
 65be used to perform operations on it. Will signal a DB-NOT-FOUND error if the database does not
 66already exist."
 67  (let ((db (make-db-object server name)))
 68    (when (db-info db)
 69      db)))
 70
 71(defun db-create (server name)
 72  "Creates a new CouchDB database. Returns a database object that can be used to operate on it. Will
 73signal a DB-ALREADY-EXISTS error if there is already a database with the same NAME in SERVER."
 74  (let ((db (make-db-object server name)))
 75    (handle-request (response db "" :method :put)
 76      (:created db)
 77      (:internal-server-error (error "Illegal database name: ~A" name))
 78      (:precondition-failed (error 'db-already-exists :uri (db-uri db))))))
 79
 80(defun ensure-db (server name)
 81  "Either connects to an existing database, or creates a new one. Returns two values: If a new
 82database was created, (DB-OBJECT T) is returned. Otherwise, (DB-OBJECT NIL)"
 83  (handler-case (values (db-create server name) t)
 84    (db-already-exists () (values (db-connect server name) nil))))
 85
 86(defun db-delete (db)
 87  "Deletes a CouchDB database."
 88  (handle-request (response db "" :method :delete)
 89    (:ok response)
 90    (:not-found (error 'db-not-found :uri (db-uri db)))))
 91
 92(defun db-compact (db)
 93  "Triggers a database compaction."
 94  (handle-request (response db "_compact" :method :post :content "")
 95    (:accepted response)))
 96
 97(defun db-changes (db)
 98  "Returns the changes feed for DB"
 99  (handle-request (response db "_changes")
100    (:ok response)))
101
102(defun db-uri (db)
103  "Returns a string representing the full URI for DB."
104  (strcat (server-uri (database-server db)) (database-name db)))
105
106;;;
107;;; Sample protocol implementation
108;;;
109(defclass standard-database ()
110  ((server :reader database-server :initarg :server)
111   (name :reader database-name))
112  (:documentation
113   "Minimal, class-based implementation of the database protocol."))
114
115(defun url-encode (string)
116  (drakma:url-encode string :utf-8))
117
118(defmethod initialize-instance :after ((db standard-database) &key name)
119  (setf (slot-value db 'name) (url-encode name)))
120
121(defmethod print-object ((db standard-database) stream)
122  (print-database db stream))
123
124(defmethod make-db-object ((server standard-server) name)
125  (make-instance 'standard-database :server server :name name))