/src/view-server/view-server.lisp
Lisp | 209 lines | 151 code | 27 blank | 31 comment | 8 complexity | 4edd966aa9bff48a7da68a73041abd21 MD5 | raw file
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))))))))