diff options
Diffstat (limited to 'lazybones-hunchentoot.lisp')
| -rw-r--r-- | lazybones-hunchentoot.lisp | 326 |
1 files changed, 0 insertions, 326 deletions
diff --git a/lazybones-hunchentoot.lisp b/lazybones-hunchentoot.lisp deleted file mode 100644 index 2b3bf1e..0000000 --- a/lazybones-hunchentoot.lisp +++ /dev/null @@ -1,326 +0,0 @@ -;; Copyright (C) 2022 Colin Okay - -;; 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/>. - - -;;;; 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)") - (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)) - |