/src/view-server/view-server.lisp

  1(defpackage #:chillax-server
  2  (:use :cl :chillax.utils)
  3  (:export :mkhash :strcat :fun :emit :hashget :log-message :validation-failure :forbidden
  4           :*user-package* :*encode-json* :*decode-json*))
  5(defpackage #:chillax-server-user
  6  (:use :cl :chillax-server))
  7(in-package :chillax-server)
  8
  9;;;
 10;;; Configuration
 11;;;
 12(defparameter *user-package* (find-package :chillax-server-user)
 13  "Package that user view functions will be compiled and executed in.")
 14(defparameter *encode-json* #'yason:encode
 15  "Function to use when encoding Lisp->JSON. Must return a string.")
 16(defparameter *decode-json* #'yason:parse
 17  "Function to use to decode JSON->Lisp. Must accept a string.")
 18
 19;;;
 20;;; Utils
 21;;;
 22(defmacro with-user-package (&body body)
 23  "Evaluates BODY in the :chillax-server-user package."
 24  `(let ((*package* *user-package*))
 25     ,@body))
 26
 27(defmacro fun (&body body)
 28  "This macro puts the FUN back in FUNCTION."
 29  `(lambda (&optional _) (declare (ignorable _)) ,@body))
 30
 31;;;
 32;;; Conditions
 33;;;
 34(define-condition chillax-server-error (error) ())
 35
 36(define-condition function-compilation-error (chillax-server-error)
 37  ((function-string :initarg :string :reader function-string))
 38  (:report (lambda (c s) (format s "Function compilation failed: ~A" (function-string c)))))
 39
 40(define-condition validation-failure (chillax-server-error)
 41  ((message :initarg :message :reader failure-message))
 42  (:report (lambda (c s) (format s "Validation failed: ~A" (failure-message c)))))
 43
 44(define-condition forbidden (validation-failure)
 45  ()
 46  (:report (lambda (c s) (format s "Operation Forbidden: ~A" (failure-message c)))))
 47
 48;;;
 49;;; User functions
 50;;;
 51(defvar *config* nil)
 52(defvar *functions*) ; holds a list of functions CouchDB is currently dealing with.
 53(defvar *function-cache* (make-hash-table :test #'equal)
 54  "Cache of compiled user functions. This is cleared whenever the reset command is run.")
 55
 56(defun ensure-view-function (maybe-function)
 57  "Returns a compiled lisp function. MAYBE-FUNCTION can be a function object or a string
 58with the source code to compile a function from."
 59  (or (when (functionp maybe-function) maybe-function)
 60      (gethash maybe-function *function-cache*)
 61      (compile-view-function maybe-function)
 62      (error "Can't return a function based on ~S" maybe-function)))
 63
 64(defun compile-view-function (string)
 65  "Compiles an anonymous function from STRING."
 66  (multiple-value-bind (function warningsp failurep)
 67      (with-user-package
 68        (compile nil (read-from-string string)))
 69    (when warningsp
 70      (log-message "A view function did not compile cleanly."))
 71    (if failurep
 72        (error 'function-compilation-error :string string)
 73        (setf (gethash string *function-cache*) function))))
 74
 75(defun call-user-function (function &rest args)
 76  (with-user-package (apply (ensure-view-function function) args)))
 77
 78(defun respond (response)
 79  (handler-case
 80      (funcall *encode-json* response)
 81    (error () (log-message "Error encoding response: ~A." response)))
 82  (terpri)
 83  (finish-output))
 84
 85;;;
 86;;; User-accessible functions
 87;;;
 88(defvar *map-results*)
 89(defun emit (key value)
 90  "Adds an entry to the current map function results."
 91  (push (list key value) *map-results*))
 92
 93(defun log-message (format-string &rest format-args)
 94  "Like FORMAT, but the resulting string is written to CouchDB's log."
 95  (format t "~&[\"log\", \"Chillax View Server: ~A\"]~%"
 96          (apply #'format nil format-string format-args))
 97  (finish-output))
 98
 99;;;
100;;; CouchDB Commands
101;;;
102(defun add-fun (string)
103  "Compiles and adds a function whose source code is in STRING to the current list of
104active CouchDB functions."
105  (push (ensure-view-function string) *functions*)
106  (respond t))
107
108(defun reset (&optional config)
109  "Resets the view server. Any caches should be emptied at this point, and any stored
110map functions should be cleared out."
111  (setf *config* config)
112  (when (boundp '*functions*)
113    (setf *functions* nil))
114  (clrhash *function-cache*)
115  (respond t))
116
117(defun call-map-function (function doc &aux *map-results*)
118  "Calls a stored compile function on a document. *MAP-RESULTS* is where EMIT will send k/v pairs."
119  (call-user-function function doc)
120  (or *map-results* '(#())))
121
122(defun map-doc (doc)
123  "Responds to CouchDB with the results of calling all the currently-active map functions on DOC."
124  (respond (or (mapcar (fun (call-map-function _ doc)) (reverse *functions*)) '((#())))))
125
126(defun reduce-results (fun-strings keys-and-values)
127  "Responds to CouchDb with the results of calling the functions in FUN-STRINGS on KEYS-AND-VALUES."
128  (loop for result in keys-and-values
129     collect (caar result) into keys
130     collect (cadr result) into values
131     finally (respond (list t (mapcar (fun (call-user-function _ keys values nil))
132                                      fun-strings)))))
133
134(defun rereduce (fun-strings values)
135  "Responds to CouchDB with the results of rereducing FUN-STRINGS on VALUES."
136  (respond (list t (mapcar (fun (call-user-function _ nil values t)) fun-strings))))
137
138(defun filter (docs req user-context)
139  "Responds to CouchDB with the result of filtering DOCS using the current filter function."
140  ;; Yes. I know it only uses the first function only. The JS view server does the same thing.
141  (respond (list t (mapcar (fun (call-user-function (car (last *functions*)) _ req user-context)) docs))))
142
143(defun validate (fun-string new-doc old-doc user-context)
144  "Executes a view function that validates NEW-DOC as a new version of OLD-DOC.
145Validation passes when the function returns normally. Validation will fail if the function errors in
146any way, and the condition's name and printout will be send to CouchDB as the exception."
147  (handler-case (progn
148                  (call-user-function fun-string new-doc old-doc user-context)
149                  (respond "1")) ; the JS server does this. Cargo cult culture dictates
150                                 ; that I should copy behavior regardless of understanding.
151    (error (e)
152      (respond (mkhash (string-downcase (princ-to-string (type-of e)))
153                       (remove #\Newline (princ-to-string e)))))))
154
155(defun ensure-response (maybe-response)
156  (if (hash-table-p maybe-response)
157      maybe-response
158      (mkhash "body" (princ-to-string maybe-response))))
159
160(defun show (fun-string doc request)
161  "Show functions are used to render documents. See CouchDB documentation for more details."
162  (respond (list "resp" (ensure-response (call-user-function fun-string doc request)))))
163
164(defun update (fun-string doc request)
165  "See CouchDB documentation for how to use _update. Functions written for the Chillax view server
166should return (values document response)."
167  (respond (multiple-value-call #'list "up" (call-user-function fun-string doc request))))
168
169;;;
170;;; View server
171;;;
172(defparameter *dispatch*
173  `(("reset" . reset)
174    ("add_fun" . add-fun)
175    ("map_doc" . map-doc)
176    ("reduce" . reduce-results)
177    ("rereduce" . rereduce)
178    ;; TODO - everything below here has changed.
179    ;;        CouchDB now uses some sort of 'DDoc'
180    ;;        thing, so this needs updating.
181    ;; ("filter" . ,#'filter)
182    ;; ("validate" . ,#'validate)
183    ;; ("show" . ,#'show)
184    ;; ("update" . ,#'update)
185    ;; ("list" . couch-list)
186    )
187  "Dispatch table holding Couch command -> Chillax function associations.")
188
189(defun run-server (&aux *functions*
190                   (black-hole (make-broadcast-stream))
191                   (*error-output* black-hole)
192                   (*debug-io* black-hole)
193                   (*trace-output* black-hole))
194  "Toplevel function that parses view requests from CouchDB and sends responses back."
195  (loop for line = (read-line *standard-input* nil nil)
196     while (< 0 (length line))
197     for (name . args) =  (funcall *decode-json* line) do
198     (handler-case
199         (let ((dispatch-result (assoc name *dispatch* :test #'string=)))
200           (if dispatch-result
201               (apply (cdr dispatch-result) args)
202               (progn
203                 (log-message "Unknown message: ~A" name)
204                 (respond (mkhash "error" "unknown_message"
205                                  "reason" "Received an unknown message from CouchDB")))))
206       (end-of-file () (return-from run-server nil))
207       (error (e)
208         (respond (mkhash "error" (princ-to-string (type-of e))
209                          "reason" (remove #\Newline (princ-to-string e))))))))