diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/package.lisp | 5 | ||||
| -rw-r--r-- | src/routes.lisp | 144 |
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)))) |