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))
+