path: root/src/backend/hunchentoot.lisp

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