path: root/lazybones-hunchentoot.lisp

;;;; 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))))
    (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*))
        (http-respond 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 (content &optional (code 200))
  "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))
                                            (when lzb:*app*
                                              (lzb::default-content-type lzb:*app*))
                                            "text/plain"))
  (if (pathnamep content)
      (h:handle-static-file content)
      content))