diff options
Diffstat (limited to 'src/backend')
| -rw-r--r-- | src/backend/hunchentoot.lisp | 323 |
1 files changed, 323 insertions, 0 deletions
diff --git a/src/backend/hunchentoot.lisp b/src/backend/hunchentoot.lisp new file mode 100644 index 0000000..acb15cb --- /dev/null +++ b/src/backend/hunchentoot.lisp @@ -0,0 +1,323 @@ +;; Copyright (C) 2022 colin@cicadas.surf + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(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)") + (domain + :accessor domain + :initarg :domain + :initform nil + :documentation "A specific domain to associate with this server + for the purposes of cookie handling. NIL by default, which is + fine.")) + (:default-initargs + :address "127.0.0.1")) + +(defvar %request-body-cache% nil + "Internal use. Dynamically bound per request. Caches the request + body after the first call to REQUEST-BODY so that subsequent calls + return the same thing, even if they've already been read off the + stream.") + +(defmethod h:acceptor-dispatch-request ((%server% lazybones-acceptor) request) + (let* ((%request-body-cache% nil) + (route + (request-path request)) + (apps + (remove-if-not (lambda (app) (a:starts-with-subseq (lzb::app-prefix app) route)) + (acceptor-apps %server%)))) + (handler-case + (loop for app in apps + 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*)) + (lzb:http-err 404))) + (lzb::http-error (http-error) + (let ((lzb:*request* request) + (lzb:*response* h:*reply*)) + (with-slots (lzb::code lzb::content) http-error + (http-respond lzb::content lzb::code)))) + (error (e) + (declare (ignorable e)) + (let ((lzb:*request* request) + (lzb:*response* h:*reply*)) + (if lzb:*debugging* + (invoke-debugger e) + (http-respond nil 500))))))) + +;;; SERVER FUNCTIONS + +(defun create-server (&key (port 8888) (address "127.0.0.1") (domain "localhost")) + "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 + :domain domain))) + (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 installed, 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))) + +(defun server-domain (&optional (server %server%)) + (domain 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. + +If WANT-STREAM-P is non-null, then an attempt is made to return a +stream from which the body content can be read. This may be impossible +if the Content-Type of the request is one of multipart/form-data or +application/x-www-form-urlencoded. + +If the body's Content-Type is application/json, multipart/form-data, +or application/x-www-form-urlencoded then a property-list +representation of the body is returned. + +Otherwise a bytevector of the body is returned. + +Work to unpack the body is performed once per request. Calling this" + (if %request-body-cache% %request-body-cache% + (setf %request-body-cache% + (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) + :as :plist + :keywords-to-read *allowed-keywords*)) + + (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 set-response-cookie + (name value + &key expires max-age path domain secure http-only (response lzb:*response*)) + "Sets the response cookie" + (apply 'h:set-cookie name + :value value + :reply response + (nconc (when expires (list :expires expires)) + (when max-age (list :max-age max-age)) + (when path (list :path path)) + (cond + (domain (list :domain domain)) + ((server-domain) (list :domain (server-domain)))) + (when secure (list :secure secure)) + (when http-only (list :http-only http-only))))) + +(defun http-respond (content) + "Final step preparing response before backend does the rest. For +Hunchentoot set 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% (response-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-header :content-type) (or (response-header :content-type) + (when (pathnamep content) + (h:mime-type content)) + (when lzb:*app* + (lzb::default-content-type lzb:*app*)) + "text/plain")) + (if (pathnamep content) + (h:handle-static-file content) + content)) + |