1 files changed, 144 insertions, 0 deletions
diff --git a/src/routes.lisp b/src/routes.lisp
new file mode 100644
index 0000000..eb66acc
--- /dev/null
+++ b/src/routes.lisp
@@ -0,0 +1,144 @@
+(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 uri 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 ((uri-bindings (gensym)))
+    (flet ((binding (name) `(,name (assoc-value ,uri-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 ,uri))
+                 (push '(,name ,(ensure-list method) ,uri) *routes-table*)))
+           (defun ,name (,headers ,uri-bindings)
+             ,@declarations
+             (write-string (http-response-header ,content-type))
+             (let (,@(mapcar #'binding (remove-if-not #'symbolp uri)))
+               ,@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)
+  (split-sequence #\/ (assoc-value headers :request-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 ((uri (request-uri headers))
+                  (method (request-method headers)))
+              (multiple-value-bind (entry bindings)
+                  (find-route uri 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))))