path: root/src/routes.lisp

(in-package #: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

(defparameter *http-methods*
  '(:get :post))

(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 "")
   (method :accessor route-method
           :initarg :method
           :type route-method
           :documentation "")
   (path :accessor route-path
         :initarg :path
         :type list
         :documentation "")
   (query :accessor route-query
          :initarg :query
          :type list
          :documentation "")
   (fragmentp :accessor route-fragment-p
             :initarg :fragmentp
             :type boolean
             :documentation "If route uses the fragment")))

(define-condition match-error ()
  ())

(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*
  '()
  "")

(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
       `(,var (or (assoc-value ,alist ',name :test #'equal)
                  ,(if suppliedp
                       `(progn (setf ,suppliedp t) ,init-form)
                       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
       `((,var (or ,value ,(if suppliedp
                               `(progn (setf ,suppliedp t) ,init-form)
                               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, which takes HEADERS and URI-BINDINGS and handles
a SCGI request. Also add entry to *ROUTES-TABLE* with the URI path of the route
and the METHOD it handles. METHOD may be a keyword or a list of keywords if the
route handles different methods."
  ;; QUERY may be a SYMBOL or a LIST of the form (BINDINGS) where each BINDINGS is either (VARIABLE &optional DEFAULT &key TEXT-FORM SETP) or VARIABLE
  ;; FRAGMENT is either as SYMBOL or (SYMBOL &optional DEFAULT SETP)
  ;; 2 routes are different only if they have either different paths or methods
  ;; using same path and method but different query or fragment results in the route being overwritten
  (check-type method http-method "a valid http method")
  (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))
                     (mapcar (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 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 uri-route (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 serve-request (stream error-handler)
  "Read SCGI header from STREAM and look for and call function handling matching
route. If no route matches, then ERROR-HANDLER is called."
  (handler-case
      (let ((*standard-output* stream)
            (headers (read-headers stream)))
        (let* ((method (assoc-value headers :request-uri))
               (uri (assoc-value headers :request-uri))
               (query-bindings (quri:uri-query-params uri))
               (route (uri-route uri)))
          (multiple-value-bind (entry path-bindings)
              (find-route route method *routes-table*)
            (if entry
                (funcall (first entry) headers path-bindings query-bindings
                         fragment)
                (funcall error-handler headers)))))
    (t (e)
      (format *error-output* "ROUTES: Error: ~A~%" e))))

(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 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 ((route (uri-route uri))
        (headers `((:request-uri . ,uri)
                   (:request-method . ,method))))
    (multiple-value-bind (entry path-bindings)
        (find-route route method *routes-table*)
      (with-accessors ((name route-name))
          entry
        (cond ((and expected-route (not (eq expected-route name)))
               (error "Unexpected match ~A" name))
              (name
               (funcall name headers
                        path-bindings
                        (quri:uri-query-params uri)
                        (quri:uri-fragment uri)))
              (t
               (error "No match")))))))

(defun default-error-handler (headers)
  (declare (ignorable headers))
  (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 server (address port &optional (error-handler 'default-error-handler))
  (usocket:socket-server address port
                         (lambda (stream)
                           (funcall 'serve-request stream error-handler))))