(in-package #:routes)

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

(defmacro define-route (name (headers &key route method 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."
  (let ((route-bindings (gensym)))
    (flet ((binding (name) `(,name (assoc-value ,route-bindings ',name))))
      (multiple-value-bind (declarations body)
          (split-declarations body)
        `(progn
           (let ((entry (assoc ',name *routes-table*)))
             (if entry
                 (setf (second entry) ',(ensure-list method)
                       (third entry) ',route)
                 (push '(,name ,(ensure-list method) ,route) *routes-table*)))
           (defun ,name (,headers ,route-bindings)
             ,@declarations
             (declare (ignorable ,route-bindings))
             (write-string (http-response-header ,content-type))
             (let (,@(mapcar #'binding (remove-if-not #'symbolp route)))
               ,@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)
           (destructuring-bind (route-name route-method route-uri) route
             (declare (ignorable route-name))
             (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-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))))
             (push (cons name value) headers))))

(defun request-method (headers)
  (switch ((assoc-value headers :request-method) :test #'equal)
    ("GET" :get)
    ("POST" :post)))

(defun request-uri (headers)
  (quri:uri (assoc-value headers :request-uri)))

(defun request-route (headers)
  (let ((uri (request-uri headers)))
    (split-sequence #\/ (quri:uri-path uri) :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)
            (length (read-request-length stream)))
        (let ((buffer (make-string (1- length))))
          (read-sequence buffer stream)
          ;; Read trailing #\Nul
          (read-char stream)
          (let ((headers (parse-headers buffer)))
            (let ((route (request-route headers))
                  (method (request-method headers)))
              (multiple-value-bind (entry bindings)
                  (find-route route method *routes-table*)
                (if entry
                    (funcall (first entry) headers bindings)
                    (funcall error-handler headers)))))))
    (t (e)
      (format *error-output* "Error: ~A~%" e))))

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