path: root/src/routes.lisp

(in-package #:scgi-routes)

;; Source: https://developer.mozilla.org/en-US/docs/Web/HTTP/Methods
;; Note: Not all http methods are yet implemented
;; Missing: :head :put :delete :connect :options :trace :patch

(define-constant +http-methods+
  '(:get :post) :test 'equal)

(deftype http-method ()
  `(member ,@+http-methods+))

(defun route-method-p (object)
  (or (typep object 'http-method)
      (and (listp object)
           (every (rcurry #'typep 'http-method) object))))

(deftype route-method ()
  `(satisfies route-method-p))

(defclass route ()
  ((name :accessor route-name
         :initarg :name
         :type symbol
         :documentation "Function name of this route's hanlder")
   (method :accessor route-method
           :initarg :method
           :type route-method
           :documentation "HTTP method or methods handled by this route")
   (path :accessor route-path
         :initarg :path
         :type list
         :documentation "Path given as a list of strings. Symbols represent
wildcards.")
   (query :accessor route-query
          :initarg :query
          :type list
          :documentation "List of variables to map from the query")
   (fragmentp :accessor route-fragment-p
              :initarg :fragmentp
              :type boolean
              :documentation "If route uses the fragment")))

(define-condition match-error (error)
  ((headers :reader match-error-headers
            :initarg :headers
            :documentation "")))

(defun translate (table string)
  "Replace charactes in STRING using replacement alist TABLE"
  (flet ((translator (x) (or (assoc-value table x) x)))
    (map 'string #'translator string)))

(defun http-response-header (content-type)
  (format nil "HTTP/1.0 200 OK~C~CContent-Type: ~A~3:*~C~C~2:*~C~C"
          #\Return #\Newline content-type))

(defparameter *routes-table*
  '()
  "Table of all routes")

(defun split-declarations (body)
  "Extract declarations and docstring from BODY"
  (flet ((declarationp (clause)
           (and (listp clause) (eq (first clause) 'declare))))
    (loop :with docstring = nil
          :for body :on body
          :for clause = (first body)
          :while (or (declarationp clause)
                     (and (not docstring) (stringp clause)))
          :collect clause :into declarations
          :when (stringp clause) :do
            (setf docstring t)
          :finally
             (return (values declarations body)))))

(defun path-binding (name alist)
  `(,name (assoc-value ,alist ',name)))

(defun query-binding (slot alist)
  (cond
    ((not slot)
     (error ""))
    ((symbolp slot)
     `((,slot (assoc-value ,alist ',(symbol-name slot)
                            :test #'string-equal))))
    ((listp slot)
     (destructuring-bind (var &key init-form name suppliedp)
         slot
       `(,@(if suppliedp `((,suppliedp t)) '())
         (,var (or (assoc-value ,alist ',name :test #'equal) ,init-form)))))
    (t
     (error ""))))

(defun fragment-binding (slot value)
  (cond
    ((not slot)
     '())
    ((symbolp slot)
     `((,slot ,value)))
    ((listp slot)
     (destructuring-bind (var &optional init-form suppliedp)
         slot
       `(,@(if suppliedp `((,suppliedp t)) '())
         (,var (or ,value ,init-form)))))
    (t
     (error ""))))

(defmacro define-route (name (&key path ; TODO: (default) "/" ?
                                (method :get)
                                query
                                fragment
                                headers
                                content-type)
                        &body body)
  "Define function NAME with BODY to handle SCGI requests. The function is added to
*ROUTES-TABLE* and called if a SCGI request uses METHOD and matches PATH. METHOD
 is either a keyword or a list of keywords from +HTTP-METHODS+. PATH is a list
 of strings specifying the path part of an uri. A symbol inside PATH denotes a
 wildcard. QUERY is a list either symbols or lists (VARIABLE &optional DEFAULT
 &key TEXT-FORM SETP) specifying the bindings in the query part of the uri.
 FRAGMENT is either a SYMBOL or (SYMBOL &optional DEFAULT SETP) and is bound to
 the fragment of the uri. HEADERS is bound to the alist of request headers. If
 CONTENT-TYPE is non-NIL, then the handler automatically generates a
 content-type line in the HTTP response, otherwise the function has to do this
 manually."
  (check-type method http-method "a valid http method")
  (check-type path list "a list")
  (when content-type
    (check-type content-type string))
  (let ((path-alist (gensym))
        (query-alist (gensym))
        (fragment-value (gensym))
        (headers-value (gensym)))
    (setf method (ensure-list method))
    (multiple-value-bind (declarations body)
        (split-declarations body)
      `(progn
         (let ((route (find ',name *routes-table* :key #'route-name)))
           (if route
               (with-accessors ((method route-method)
                                (path route-path)
                                (query route-query)
                                (fragmentp route-fragment-p))
                   route
                 (setf method ',method
                       path ',path
                       query ',query
                       fragmentp ',fragment))
               (push (make-instance 'route :name ',name
                                           :method ',method
                                           :path ',path
                                           :query ',query
                                           :fragmentp ',fragment)
                     *routes-table*)))
         (defun ,name (,headers-value ,path-alist ,query-alist
                       ,fragment-value)
           ,@declarations
           (declare (ignorable ,headers-value ,path-alist ,query-alist
                               ,fragment-value))
           ,(when content-type
              `(write-string (http-response-header ,content-type)))
           (let (,@(append
                     (mapcar (rcurry #'path-binding path-alist)
                             (remove-if-not #'symbolp path))
                     (mappend (rcurry #'query-binding query-alist)
                              query)
                     (fragment-binding fragment fragment-value)
                     (if headers `((,headers ,headers-value)) '())))
             ,@body))))))

(defun match-route (pattern route)
  "Match PATTERN to ROUTE, returns alist with bindings or T if no free variables
are present. If no match is possible, NIL is returned instead"
  (do ((pattern pattern (rest pattern))
       (route route (rest route))
       (bindings '()))
      ((and (null pattern) (null route))
       (or bindings t))
    (cond ((or (null pattern) (null route))
           (return nil))
          ((symbolp (first pattern))
           (push (cons (first pattern) (first route)) bindings))
          ((not (equalp (first pattern) (first route)))
           (return nil)))))

(defun find-route (uri method routes-table)
  "Find matching route for request inside of ROUTES-TABLE. If multiple routes are
compatible with the requests URI and METHOD, then the match with the least
amount of bindings, i.e. the most specific match, is returned."
  (flet ((bind-route (route)
           (with-accessors ((route-method route-method)
                            (route-uri route-path))
               route
             (let ((match (and (find method route-method)
                               (match-route route-uri uri))))
               (if match
                   (list route (if (eq match t) '() match))
                   nil))))
         (match-length (match) (length (first match))))
    (let ((routes (remove nil (mapcar #'bind-route routes-table))))
      (if routes
          (values-list (first (sort routes #'< :key #'match-length)))
          nil))))

(defun read-request-length (stream)
  "Get the first characters in STREAM representing the length of the request's
header."
  (let ((chars (loop :for c = (read-char stream) :while (char/= c #\:)
                     :collect c)))
    (parse-integer (coerce chars 'string))))

(defun parse-method (method)
  (switch (method :test #'string-equal)
    ("GET" :get)
    ("POST" :post)))

(defun ensure-uri (uri)
  "If URI is an instance QURI:URI, it is returned. Otherwise parse URI into a valid
QURI:URI object."
  (etypecase uri
    (string (quri:uri uri))
    (quri:uri uri)))

(defun route-path-from-uri (uri)
  "Split the path of an URI for route pattern matching."
  (let ((path (quri:uri-path uri)))
    (split-sequence #\/ path :remove-empty-subseqs t)))

(defun parse-headers (string &aux headers)
  "Split SCGI header inside STRING into key value alist."
  (doplist (sname value (split-sequence #\Nul string) headers)
           (let* ((name (make-keyword (translate '((#\_ . #\-)) sname)))
                  (value (case name
                           (:request-uri (quri:uri value))
                           (:request-method (parse-method value))
                           (t value))))
             (push (cons name value) headers))))

(defun read-headers (stream)
  ""
  (let* ((length (read-request-length stream))
         (buffer (make-string (1- length))))
    (read-sequence buffer stream)
    (read-char stream) ; Read trailing #\Nul
    (parse-headers buffer)))

(defun serve-request (stream)
  "Read SCGI header from STREAM and look for and call function handling matching
route."
  (let* ((headers (read-headers stream))
         (uri (assoc-value headers :request-uri)))
    (multiple-value-bind (entry path-bindings)
        (find-route (route-path-from-uri uri)
                    (assoc-value headers :request-method)
                    *routes-table*)
      (unless entry
        (error 'match-error :headers headers))
      (let ((*standard-output* stream))
        (funcall (route-name entry)
                 headers
                 path-bindings
                 (quri:uri-query-params uri)
                 (quri:uri-fragment uri))))))

(defun test-route (method uri &optional expected-route)
  "Find route handler for METHOD request URI, compare if route resolves to
EXPECTED-ROUTE and test the route handler without running a server.  Used for
writing possibly offline tests for route handlers"
  (check-type method http-method)
  (setf uri (ensure-uri uri))
  (let ((path (route-path-from-uri uri))
        (headers `((:request-uri . ,uri)
                   (:request-method . ,method))))
    (multiple-value-bind (entry path-bindings)
        (find-route path method *routes-table*)
      (when (and expected-route (not (eq expected-route name)))
        (error "Unexpected match ~A" name))
      (unless entry
        (error 'match-error :headers headers))
      (funcall (route-name entry)
               headers
               path-bindings
               (quri:uri-query-params uri)
               (quri:uri-fragment uri)))))

(defun default-error-handler (stream condition)
  (declare (ignorable condition))
  (let ((*standard-output* stream))
    (write-string (http-response-header "text/html"))
    (write-string "<!DOCTYPE html>
<html>
    <head><title>404 Not Found</title></head>
    <body><h1>404 Not Found</h1></body>
</html>")))

(defun default-internal-error-handler (stream condition)
  (declare (ignorable headers))
  (let ((*standard-output* stream))
    (write-string (http-response-header "text/html"))
    (write-string "<!DOCTYPE html>
<html>
    <head><title>500 Internal Server Error</title></head>
    <body><h1>500 Internal Server Error</h1></body>
</html>")))

(defun socket-function (stream match-error-handler internal-error-handler)
  (handler-case
      (serve-request stream)
    (match-error (c)
      (funcall match-error-handler stream c))
    (t (c)
      (funcall internal-error-handler stream c)
      (format *error-output* "~&ROUTES: Unhandled error:~%~A~%" c))))

(defun server (address port
               &optional
                 (match-error-handler 'default-error-handler)
                 (internal-error-handler 'default-internal-error-handler))
  (usocket:socket-server address port (rcurry #'socket-function
                                              match-error-handler
                                              internal-error-handler)))