Add types and support for query and fragment bindings

2 files changed, 204 insertions, 50 deletions

diff --git a/src/package.lisp b/src/package.lisp
index 38a67f7..c2ea5b2 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -4,7 +4,7 @@
         #:split-sequence)
   (:export #:define-route
            #:server
-
+           #:test-route
            #:request-method
            #:request-route
            #:request-uri))
diff --git a/src/routes.lisp b/src/routes.lisp
index 502afca..8303b14 100644
--- a/src/routes.lisp
+++ b/src/routes.lisp
@@ -1,5 +1,48 @@
 (in-package #:routes)
 
+;; Source: https://developer.mozilla.org/en-US/docs/Web/HTTP/Methods
+;; Note: Not all http methods are yet implemented
+;; Missing: :head :put :delete :connect :options :trace :patch
+
+(defparameter *http-methods*
+  '(:get :post))
+
+(deftype http-method ()
+  `(member ,@*http-methods*))
+
+(defun route-method-p (object)
+  (or (typep object 'http-method)
+      (and (listp object)
+           (every (rcurry #'typep 'http-method) object))))
+
+(deftype route-method ()
+  `(satisfies route-method-p))
+
+(defclass route ()
+  ((name :accessor route-name
+         :initarg :name
+         :type symbol
+         :documentation "")
+   (method :accessor route-method
+           :initarg :method
+           :type route-method
+           :documentation "")
+   (path :accessor route-path
+         :initarg :path
+         :type list
+         :documentation "")
+   (query :accessor route-query
+          :initarg :query
+          :type list
+          :documentation "")
+   (fragmentp :accessor route-fragment-p
+             :initarg :fragmentp
+             :type boolean
+             :documentation "If route uses the fragment")))
+
+(define-condition match-error ()
+  ())
+
 (defun translate (table string)
   "Replace charactes in STRING using replacement alist TABLE"
   (flet ((translator (x) (or (assoc-value table x) x)))
@@ -28,26 +71,98 @@
           :finally
              (return (values declarations body)))))
 
-(defmacro define-route (name (headers &key route method content-type) &body body)
+(defun path-binding (name alist)
+  `(,name (assoc-value ,alist ',name)))
+
+(defun query-binding (slot alist)
+  (cond
+    ((not slot)
+     (error ""))
+    ((symbolp slot)
+     `(,slot (assoc-value ,alist ',(symbol-name slot)
+                          :test #'string-equal)))
+    ((listp slot)
+     (destructuring-bind (var &key init-form name suppliedp)
+         slot
+       `(,var (or (assoc-value ,alist ',name :test #'equal)
+                  ,(if suppliedp
+                       `(progn (setf ,suppliedp t) ,init-form)
+                       init-form)))))
+    (t
+     (error ""))))
+
+(defun fragment-binding (slot value)
+  (cond
+    ((not slot)
+     '())
+    ((symbolp slot)
+     `((,slot ,value)))
+    ((listp slot)
+     (destructuring-bind (var &optional init-form suppliedp)
+         slot
+       `((,var (or ,value ,(if suppliedp
+                               `(progn (setf ,suppliedp t) ,init-form)
+                               init-form))))))
+    (t
+     (error ""))))
+
+(defmacro define-route (name (&key path ; TODO: (default) "/" ?
+                                (method :get)
+                                query
+                                fragment
+                                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."
-  (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)))))))
+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
+  (check-type method http-method "a valid http method")
+  (check-type content-type string)
+  (let ((path-alist (gensym))
+        (query-alist (gensym))
+        (fragment-value (gensym))
+        (headers-value (gensym)))
+    (setf method (ensure-list method))
+    (multiple-value-bind (declarations body)
+        (split-declarations body)
+      `(progn
+         (let ((route (find ',name *routes-table* :key #'route-name)))
+           (if route
+               (with-accessors ((method route-method)
+                                (path route-path)
+                                (query route-query)
+                                (fragmentp route-fragment-p))
+                   route
+                 (setf method ',method
+                       path ',path
+                       query ',query
+                       fragmentp ',fragment))
+               (push (make-instance 'route :name ',name
+                                           :method ',method
+                                           :path ',path
+                                           :query ',query
+                                           :fragmentp ',fragment)
+                     *routes-table*)))
+         (defun ,name (,headers-value ,path-alist ,query-alist
+                       ,fragment-value)
+           ,@declarations
+           (declare (ignorable ,headers-value ,path-alist ,query-alist
+                               ,fragment-value))
+           ,(when content-type
+              `(write-string (http-response-header ,content-type)))
+           (let (,@(append
+                     (mapcar (rcurry #'path-binding path-alist)
+                             (remove-if-not #'symbolp path))
+                     (mapcar (rcurry #'query-binding query-alist)
+                             query)
+                     (fragment-binding fragment fragment-value)
+                     (if headers `((,headers ,headers-value)) '())))
+             ,@body))))))
 
 (defun match-route (pattern route)
   "Match PATTERN to ROUTE, returns alist with bindings or T if no free variables
@@ -69,8 +184,9 @@ are present. If no match is possible, NIL is returned instead"
 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))
+           (with-accessors ((route-method route-method)
+                            (route-uri route-path))
+               route
              (let ((match (and (find method route-method)
                                (match-route route-uri uri))))
                (if match
@@ -89,44 +205,82 @@ header."
                      :collect c)))
     (parse-integer (coerce chars 'string))))
 
+(defun parse-method (method)
+  (switch (method :test #'string-equal)
+    ("GET" :get)
+    ("POST" :post)))
+
 (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))))
+           (let* ((name (make-keyword (translate '((#\_ . #\-)) sname)))
+                  (value (case name
+                           (:request-uri (quri:uri value))
+                           (:request-method (parse-method value))
+                           (t value))))
              (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 read-headers (stream)
+  ""
+  (let* ((length (read-request-length stream))
+         (buffer (make-string (1- length))))
+    (read-sequence buffer stream)
+    (read-char stream) ; Read trailing #\Nul
+    (parse-headers buffer)))
 
-(defun request-route (headers)
-  (let ((uri (request-uri headers)))
-    (split-sequence #\/ (quri:uri-path uri) :remove-empty-subseqs t)))
+(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)
   "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)))))))
+            (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)))
+          (multiple-value-bind (entry path-bindings)
+              (find-route route method *routes-table*)
+            (if entry
+                (funcall (first entry) headers path-bindings query-bindings
+                         fragment)
+                (funcall error-handler headers)))))
     (t (e)
-      (format *error-output* "Error: ~A~%" 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)))
+
+(defun test-route (method uri &optional expected-route)
+  "Find route handler for METHOD request URI, compare if route resolves to
+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))
+        (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")))))))
 
 (defun default-error-handler (headers)
   (declare (ignorable headers))
@@ -142,7 +296,7 @@ route. If no route matches, then ERROR-HANDLER is called."
     </body>
 </html>"))
 
-(defun server (address port &optional (error-handler #'default-error-handler))
+(defun server (address port &optional (error-handler 'default-error-handler))
   (usocket:socket-server address port
-                         #'(lambda (stream)
-                             (funcall 'serve-request stream error-handler))))
+                         (lambda (stream)
+                           (funcall 'serve-request stream error-handler))))