;;;; lazybones-hunchentoot.lisp -- hunchentoot backend for lazybones (defpackage #:lazybones.backend/hunchentoot (:use #:cl #:lazybones.backend) (:local-nicknames (#:h #:hunchentoot) (#:lzb #:lazybones) (#:a #:alexandria))) (in-package :lazybones.backend/hunchentoot) ;;; Hunchentoot Acceptor Subclass (defvar %server nil "unexported defvar holding the lazybones-acceptor instance.") (defclass lazybones-acceptor (h:acceptor) ((installed-apps :accessor acceptor-apps :initform nil :documentation "Instances of LAZYBONES:APP installed to this acceptor. APPs are, among other things, collections of ENDPOINT instances. The acceptor instance uses them to dispatch handlers on requests.") (canned-responses :accessor canned-responses :initarg :canned-responses :initform nil :documentation "an alist of (CODE CONTENT-FUNCTION CONTENT-TYPE)")) (:default-initargs :address "127.0.0.1")) (defmethod h:acceptor-dispatch-request ((%server lazybones-acceptor) request) (handler-case (loop for app in (acceptor-apps %server) for (endpoint . args) = (lzb::find-endpoint app request) when endpoint return (lzb::run-endpoint endpoint args request h:*reply* app) ;; if no endpoint was found, call next method. finally (let ((lzb:*request* request) (lzb:*response* h:*reply*)) (return (lzb:http-err 404)))) (error (e) (declare (ignorable e)) (let ((lzb:*request* request) (lzb:*response* h:*reply*)) (lzb:http-err 500))))) ;;; SERVER FUNCTIONS (defun create-server (&key (port 8888) (address "127.0.0.1")) "Creates an opaque server on port PORT, and returns it. Servers are backend specific, but each may be passed in to INSTALL-APP, UNINSTALL-APP, START-SERVER, and STOP-SERVER." (let ((server (make-instance 'lazybones-acceptor :port port :address address))) (set-canned-response server 404 "Not Found" "text/plain") (set-canned-response server 500 "Server Error" "text/plain") server)) (defun start-server (server) (h:start server)) (defun stop-server (server) (h:stop server)) (defun install-app (server app) "Installs a LAZYBONES:APP instance to SERVER, first checking that the app exists. If app is already isntalled, does nothing." (a:if-let (app (and app (if (symbolp app) (lzb:app app) app))) (pushnew app (acceptor-apps server) :key 'lzb::app-name) (error () "No app to install."))) (defun uninstall-app (server app) (setf (acceptor-apps server) (delete (if (symbolp app) (lzb:app app) app) (acceptor-apps server)))) (defun canned-response (server code) "If a canned response is installed to the server for the HTTP response code CODE, return it as a list (RESPONSE-SOURCE CONTENT-TYPE). RESPONSE-SOURCE is either a function designator for a function taking zero arguments that is expected to return data that matches the CONTENT-TYPE. Such a function can always make use of *REQUEST*. RESPONSE-SOURCE can also be a pathname to a file to serve." (cdr (assoc code (canned-responses server)))) (defun set-canned-response (server code content-source content-type) "Set a new canned response for the code CODE." (push (list code content-source content-type) (canned-responses server))) ;;; HTTP REQUEST FUNCTIONS (defun request-path (&optional (request lzb:*request* )) "Returns the PATH part of the REQUEST URL. See Also: https://en.wikipedia.org/wiki/URL#Syntax." (h:script-name request)) (defun request-host (&optional (request lzb:*request*)) "Returns the HOST part of the REQUEST URL. See Also: https://en.wikipedia.org/wiki/URL#Syntax" (h:host request)) (defun request-url (&optional (request lzb:*request*)) "Returns the full url of REQUST" (h:request-uri* request)) (defun request-port (&optional (request lzb:*request*)) "The port associated with REQUEST." (h:local-port* request)) (defun request-query-string (&optional (request lzb:*request*)) "Returns the full query string of the URL associated with REQUEST See Also: https://en.wikipedia.org/wiki/URL#Syntax" (h:query-string request)) (defun request-parameter (name &optional (request lzb:*request*)) "Returns the the value of the query parameter named NAME, or NIL if there there is none." (h:get-parameter name request)) (defun request-parameters (&optional (request lzb:*request*)) "Returns an alist of parameters associated with REQUEST. Each member of the list looks like (NAME . VALUE) where both are strings." (h:get-parameters request)) (defun request-headers (&optional (request lzb:*request*)) "Returns an alist of headers associated with REQUEST. Each member of the list looks like (HEADER-NAME . VALUE) where HEADER-NAME is a keyword or a string and VALUE is a string." (h:headers-in request)) (defun request-header (header-name &optional (request lzb:*request*)) "Returns the string value of the REQUEST header named HEADER-NAME. HEADER-NAME can be a keyword or a string." (h:header-in header-name request)) (defun request-cookie (name &optional (request lzb:*request*)) "Returns the cookie with NAME sent with the REQUEST" (h:cookie-in name request)) (defun request-method (&optional (request lzb:*request*)) "Returns a keyword representing the http method of the request." (h:request-method request)) (defparameter +hunchentoot-pre-decoded-content-types+ '("multipart/form-data" "application/x-www-form-urlencoded")) (defun pre-decoded-body-p (request) (let ((header (request-header :content-type request))) (when (stringp header) (loop for prefix in +hunchentoot-pre-decoded-content-types+ thereis (a:starts-with-subseq prefix header))))) (defparameter +hunchentoot-methods-with-body+ '(:post :put :patch)) (defun request-body (&key (request lzb:*request*) (want-stream-p nil)) "Returns the decoded request body. The value returned depends upon the value of the Content-Type request header." (when (member (request-method request) +hunchentoot-methods-with-body+) (let ((pre-decoded-body-p (pre-decoded-body-p request)) (content-type (request-header :content-type request))) (cond ;; try to get a stream on request (want-stream-p ;; can't do it if the body is already decoded - return nil so ;; that request-body can be called again (unless pre-decoded-body-p (h:raw-post-data :request request :want-stream t))) (pre-decoded-body-p (format-as-lazybones-document (h:post-parameters request))) ((string-equal "application/json" content-type) (jonathan:parse (h:raw-post-data :request request :external-format :utf8 ))) ; TODO don't hardcode the format (t ;; default case is to return a bytevector (h:raw-post-data :request request :force-binary t)))))) (defun format-as-lazybones-document (post-parameters) "internal function. Formats all the post parmaeters (see docstring on hunchentoot:post-parameters) into a plist with keyword keys, as is the convention for lazybones." (loop for (k . value) in post-parameters collect (alexandria:make-keyword k) collect value)) ;;; HTTP RESPONSE FUNCTIONS (defun response-code (&optional (response lzb:*response*)) "Access the return code of the resposne. Return code should be an integer." (h:return-code response)) (defun (setf response-code) (code &optional (response lzb:*response*)) (setf (h:return-code response) code)) (defun response-header (name &optional (response lzb:*response*)) "Access the response header that has NAME, which can be a keyword (recommended) or a string." (h:header-out name response)) (defun (setf response-header) (value name &optional (response lzb:*response*)) (setf (h:header-out name response) value)) (defun response-cookie (name &optional (response lzb:*response*)) "Access the cookie with NAME in the response object." (h:cookie-out name response)) (defun (setf response-cookie) (value name &optional (response lzb:*response*)) (a:if-let (extant-cookie (assoc name (h:cookies-out response) :test #'string=)) (setf (cdr extant-cookie) value) (cadar (setf (h:cookies-out response) (cons (cons name value) (h:cookies-out response)))))) (defun http-respond (code content) "Final step preparing response before backend does the rest. For Hunchentoot, set the response code and a few headers. If content is a pathname, pass off to HUNCHENTOOT:HANDLE-STATIC-FILE, otherwise just return the content." ;; When http-err is called, the content is likely to be null. If ;; that is the case, look for the default content for the error ;; code, and set content and content-type appropriately (a:when-let (data (and (null content) (canned-response %server code))) (destructuring-bind (source content-type) data (setf (response-header :content-type) content-type content (if (or (functionp source) (symbolp source)) (funcall source) source)))) ;; set the response code and header. (setf (response-code) code (response-header :content-type) (or (response-header :content-type) (when (pathnamep content) (h:mime-type content)) (lzb::default-content-type lzb:*app*) (error "Content Type Not Set"))) (if (pathnamep content) (h:handle-static-file content) content))