/src/core/server.lisp

  1(in-package :chillax.core)
  2
  3;;;
  4;;; Status codes
  5;;;
  6(defparameter +status-codes+
  7  '((200 . :ok)
  8    (201 . :created)
  9    (202 . :accepted)
 10    (304 . :not-modified)
 11    (400 . :bad-request)
 12    (404 . :not-found)
 13    (405 . :resource-not-allowed)
 14    (409 . :conflict)
 15    (412 . :precondition-failed)
 16    (415 . :bad-content-type)
 17    (500 . :internal-server-error))
 18  "A simple alist of keyword names for HTTP status codes, keyed by status code.")
 19
 20(defparameter +utf-8+ (make-external-format :utf-8 :eol-style :lf))
 21
 22;;;
 23;;; Conditions
 24;;;
 25(define-condition couchdb-error () ())
 26
 27(define-condition unexpected-response (couchdb-error)
 28  ((status-code :initarg :status-code :reader error-status-code)
 29   (response :initarg :response :reader error-response))
 30  (:report (lambda (condition stream)
 31             (format stream "Unexpected response with status code: ~A~@
 32                             HTTP Response: ~A~@
 33                             Please report this to Chillax's maintainer(s)"
 34                     (error-status-code condition)
 35                     (error-response condition)))))
 36
 37;;;
 38;;; Server API
 39;;;
 40
 41;; Server Protocol
 42(defgeneric server-host (server))
 43(defgeneric server-port (server))
 44(defgeneric server-username (server))
 45(defgeneric server-password (server))
 46(defgeneric server-secure-p (server))
 47(defgeneric data->json (server data &key)
 48  (:documentation "Converts DATA to JSON suitable for sending to CouchDB."))
 49(defgeneric json->data (server json &key)
 50  (:documentation "Converts JSON to the desired data structure."))
 51(defgeneric make-db-object (server name)
 52  (:documentation
 53"Creates an object which represents a database connection in SERVER. The object must conform to the
 54database protocol."))
 55
 56(defun couch-request (server uri &rest all-keys
 57                      &key (content nil contentp) (convert-data-p t)
 58                      &allow-other-keys)
 59  "Sends an HTTP request to the CouchDB server represented by SERVER. Most of the keyword arguments
 60for drakma:http-request are available as kwargs for this message."
 61  (let* ((content (cond ((and contentp convert-data-p)
 62                        (data->json server content))
 63                       ((and contentp (not convert-data-p))
 64                        content)
 65                       (t "")))
 66         (content-length (or (getf all-keys :content-length)
 67                             (flex:octet-length content :external-format +utf-8+))))
 68    (remf all-keys :content-length)
 69    (remf all-keys :convert-data-p)
 70    (multiple-value-bind (response status-code)
 71        (apply #'http-request (strcat (server-uri server) uri)
 72               :content-type "application/json"
 73               :external-format-out +utf-8+
 74               :external-format-in +utf-8+
 75               :basic-authorization (when (server-username server)
 76                                      (list (server-username server)
 77                                            (server-password server)))
 78               :content content
 79               :content-length content-length
 80               all-keys)
 81      (values (json->data server response)
 82              (or (cdr (assoc status-code +status-codes+ :test #'=))
 83                  ;; The code should never get here once we know all the
 84                  ;; status codes CouchDB might return.
 85                  (error "Unknown status code: ~A. HTTP Response: ~A"
 86                         status-code response))))))
 87
 88;; Server functions
 89(defun server-uri (server)
 90  "Returns a string representation of the URL SERVER represents."
 91  (format nil "~A://~A:~A/"
 92          (if (server-secure-p server)
 93              "https"
 94              "http")
 95          (server-host server)
 96          (server-port server)))
 97
 98(defun all-dbs (server)
 99  "Requests a list of all existing databases from SERVER."
100  (couch-request server "_all_dbs"))
101
102(defun config-info (server)
103  "Requests the current configuration from SERVER."
104  (couch-request server "_config"))
105
106(defun replicate (server source target &key create-target-p continuousp
107                  &aux (to-json `("source" ,source "target" ,target)))
108  "Replicates the database in SOURCE to TARGET. SOURCE and TARGET can both be either database names
109in the local server, or full URLs to local or remote databases. If CREATE-TARGET-P is true, the
110target database will automatically be created if it does not exist. If CONTINUOUSP is true, CouchDB
111will continue propagating any changes in SOURCE to TARGET."
112  ;; There are some caveats to the keyword arguments -
113  ;; create-target-p: doesn't actually seem to work at all in CouchDB 0.10
114  ;; continuousp: The CouchDB documentation warns that this continuous replication
115  ;;              will only last as long as the CouchDB daemon is running. If the
116  ;;              daemon is restarted, replication must be restarted as well.
117  ;;              Note that there are plans to add 'persistent' replication.
118  (when create-target-p (setf to-json (append `("create_target" "true") to-json)))
119  (when continuousp (setf to-json (append `("continuous" "true") to-json)))
120  (couch-request server "_replicate" :method :post :content (format nil "{~{~s:~s~^,~}}" to-json)))
121
122(defun stats (server)
123  "Requests general statistics from SERVER."
124  (couch-request server "_stats"))
125
126(defun active-tasks (server)
127  "Lists all the currently active tasks on SERVER."
128  (couch-request server "_active_tasks"))
129
130(defun get-uuids (server &key (number 10))
131  "Returns a list of NUMBER unique IDs requested from SERVER. The UUIDs generated by the server are
132reasonably unique, but are not checked against existing UUIDs, so conflicts may still happen."
133  (couch-request server (format nil "_uuids?count=~A" number)))
134
135;;;
136;;; Sample protocol implementation
137;;;
138(defclass standard-server ()
139  ((host
140    :reader server-host
141    :initarg :host)
142   (port
143    :reader server-port
144    :initarg :port)
145   (username
146    :reader server-username
147    :initarg :username)
148   (password
149    :reader server-password
150    :initarg :password)
151   (securep
152    :reader server-secure-p
153    :initarg :securep))
154  (:documentation
155   "Default implementation of the server protocol.")
156  (:default-initargs
157      :host "127.0.0.1"
158    :port 5984
159    :username nil
160    :password nil
161    :securep nil))
162
163(defmethod data->json ((server standard-server) data &key)
164  data)
165(defmethod json->data ((server standard-server) json &key)
166  json)