From bd07f91d1f2ad91f53789f993c75e3c794f48a56 Mon Sep 17 00:00:00 2001
From: Thomas Albers Raviola <thomas@thomaslabs.org>
Date: Fri, 18 Oct 2024 22:33:08 +0200
Subject: Improved documentation

---
 src/routes.lisp | 174 +++++++++++++++++++++++++++++++-------------------------
 1 file changed, 98 insertions(+), 76 deletions(-)

diff --git a/src/routes.lisp b/src/routes.lisp
index 0de0307..6a9ec14 100644
--- a/src/routes.lisp
+++ b/src/routes.lisp
@@ -22,26 +22,29 @@
   ((name :accessor route-name
          :initarg :name
          :type symbol
-         :documentation "")
+         :documentation "Function name of this route's hanlder")
    (method :accessor route-method
            :initarg :method
            :type route-method
-           :documentation "")
+           :documentation "HTTP method or methods handled by this route")
    (path :accessor route-path
          :initarg :path
          :type list
-         :documentation "")
+         :documentation "Path given as a list of strings. Symbols represent
+wildcards.")
    (query :accessor route-query
           :initarg :query
           :type list
-          :documentation "")
+          :documentation "List of variables to map from the query")
    (fragmentp :accessor route-fragment-p
-             :initarg :fragmentp
-             :type boolean
-             :documentation "If route uses the fragment")))
+              :initarg :fragmentp
+              :type boolean
+              :documentation "If route uses the fragment")))
 
-(define-condition match-error ()
-  ())
+(define-condition match-error (error)
+  ((headers :reader match-error-headers
+            :initarg :headers
+            :documentation "")))
 
 (defun translate (table string)
   "Replace charactes in STRING using replacement alist TABLE"
@@ -54,7 +57,7 @@
 
 (defparameter *routes-table*
   '()
-  "")
+  "Table of all routes")
 
 (defun split-declarations (body)
   "Extract declarations and docstring from BODY"
@@ -110,16 +113,21 @@
                                 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
+  "Define function NAME with BODY to handle SCGI requests. The function is added to
+*ROUTES-TABLE* and called if a SCGI request uses METHOD and matches PATH. METHOD
+ is either a keyword or a list of keywords from +HTTP-METHODS+. PATH is a list
+ of strings specifying the path part of an uri. A symbol inside PATH denotes a
+ wildcard. QUERY is a list either symbols or lists (VARIABLE &optional DEFAULT
+ &key TEXT-FORM SETP) specifying the bindings in the query part of the uri.
+ FRAGMENT is either a SYMBOL or (SYMBOL &optional DEFAULT SETP) and is bound to
+ the fragment of the uri. HEADERS is bound to the alist of request headers. If
+ CONTENT-TYPE is non-NIL, then the handler automatically generates a
+ content-type line in the HTTP response, otherwise the function has to do this
+ manually."
   (check-type method http-method "a valid http method")
-  (check-type content-type string)
+  (check-type path list "a list")
+  (when content-type
+    (check-type content-type string))
   (let ((path-alist (gensym))
         (query-alist (gensym))
         (fragment-value (gensym))
@@ -207,6 +215,18 @@ header."
     ("GET" :get)
     ("POST" :post)))
 
+(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 route-path-from-uri (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 parse-headers (string &aux headers)
   "Split SCGI header inside STRING into key value alist."
   (doplist (sname value (split-sequence #\Nul string) headers)
@@ -225,37 +245,23 @@ header."
     (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)
+(defun serve-request (stream)
   "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))
-               (fragment (quri:uri-fragment uri)))
-          (multiple-value-bind (entry path-bindings)
-              (find-route route method *routes-table*)
-            (if entry
-                (funcall (route-name 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)))
+route."
+  (let* ((headers (read-headers stream))
+         (uri (assoc-value headers :request-uri)))
+    (multiple-value-bind (entry path-bindings)
+        (find-route (route-path-from-uri uri)
+                    (assoc-value headers :request-method)
+                    *routes-table*)
+      (unless entry
+        (error 'match-error :headers headers))
+      (let ((*standard-output* stream))
+        (funcall (route-name entry)
+                 headers
+                 path-bindings
+                 (quri:uri-query-params uri)
+                 (quri:uri-fragment uri))))))
 
 (defun test-route (method uri &optional expected-route)
   "Find route handler for METHOD request URI, compare if route resolves to
@@ -263,38 +269,54 @@ 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))
+  (let ((path (route-path-from-uri 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")))))))
+        (find-route path method *routes-table*)
+      (when (and expected-route (not (eq expected-route name)))
+        (error "Unexpected match ~A" name))
+      (unless entry
+        (error 'match-error :headers headers))
+      (funcall (route-name entry)
+               headers
+               path-bindings
+               (quri:uri-query-params uri)
+               (quri:uri-fragment uri)))))
 
-(defun default-error-handler (headers)
+(defun default-error-handler (stream condition)
+  (declare (ignorable condition))
+  (let ((*standard-output* stream))
+    (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 default-internal-error-handler (stream condition)
   (declare (ignorable headers))
-  (write-string (http-response-header "text/html"))
-  (write-string "<!DOCTYPE html>
+  (let ((*standard-output* stream))
+    (write-string (http-response-header "text/html"))
+    (write-string "<!DOCTYPE html>
 <html>
-    <head>
-        <title>404 Not Found</title>
-    </head>
+    <head><title>500 Internal Server Error</title></head>
+    <body><h1>500 Internal Server Error</h1></body>
+</html>")))
 
-    <body>
-        <h1>404 Not Found</h1>
-    </body>
-</html>"))
+(defun socket-function (stream match-error-handler internal-error-handler)
+  (handler-case
+      (serve-request stream)
+    (match-error (c)
+      (funcall match-error-handler stream c))
+    (t (c)
+      (funcall internal-error-handler stream c)
+      (format *error-output* "~&ROUTES: Unhandled error:~%~A~%" c))))
 
-(defun server (address port &optional (error-handler 'default-error-handler))
-  (usocket:socket-server address port
-                         (lambda (stream)
-                           (funcall 'serve-request stream error-handler))))
+(defun server (address port
+               &optional
+                 (match-error-handler 'default-error-handler)
+                 (internal-error-handler 'default-internal-error-handler))
+  (usocket:socket-server address port (rcurry #'socket-function
+                                              match-error-handler
+                                              internal-error-handler)))
-- 
cgit v1.2.3