aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorThomas Albers Raviola <thomas@thomaslabs.org>2024-05-03 20:04:14 +0200
committerThomas Albers Raviola <thomas@thomaslabs.org>2024-05-03 20:04:14 +0200
commit7497f74f5eed855e8114f82860faccfc8935b5cc (patch)
treec92444ed7daa80daa8838d46b6a9ea9679f510dc /src
* Initial commit
Diffstat (limited to 'src')
-rw-r--r--src/package.lisp5
-rw-r--r--src/routes.lisp144
2 files changed, 149 insertions, 0 deletions
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..7a16b91
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,5 @@
+(defpackage #:routes
+ (:use #:cl
+ #:alexandria
+ #:split-sequence)
+ (:export))
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))))