Primordial router

1 files changed, 46 insertions, 2 deletions

diff --git a/weeb/router.scm b/weeb/router.scm
index 8c4b502..575860b 100644
--- a/weeb/router.scm
+++ b/weeb/router.scm
@@ -17,9 +17,12 @@
 ;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
 
 (define-module (weeb router)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
   #:use-module (weeb struct)
-  #:export (define-router))
+  #:export (define-router
+             iter-routes))
 
 (define (uri-template->regexp-string template)
   ;; TODO: Assert that the first character is a slash.
@@ -30,9 +33,50 @@
              (if variable-match
                  (list (string->symbol (match:substring variable-match 1)) "([^/]+)")
                  (list #f component))))
-         (string-split (if trailing-slash?
+         (string-split (if (and trailing-slash? (not (string= template "/")))
                            (substring template 1 (- (string-length template) 1))
                            (substring template 1))
                        #\/)))
   (values (string-append "/" (string-join (map cadr components) "/"))
           (filter symbol? (map car components))))
+
+(define (handle-route request route-object)
+  (define (ladder-parameters match-object n)
+    (map (lambda (n) (match:substring match-object (+ 1 n)))
+         (iota n)))
+  (with-accessors (request method uri)
+    (match route-object
+      ((route-regexp route-variables route-methods proc)
+       (let ((match-object (regexp-exec route-regexp uri)))
+         (if (and (memq method route-methods) match-object)
+             ;; Unfortunately can't reflect on procedure names. We *could*, I
+             ;; suppose, pass them as keyword arguments, but I think I want to
+             ;; rethink this interface in the future.
+             (apply proc request (ladder-parameters match-object (length route-variables)))
+             #f))))))
+
+(define-syntax %handle-route
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ (template methods proc))
+       #'(let-values (((regexp-string variables) (uri-template->regexp-string template)))
+           (let ((regexp (make-regexp regexp-string)))
+             (list regexp variables (quote methods) proc)))))))
+
+(define-syntax define-router
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ name route* ...)
+       #'(define name (list (%handle-route route*) ...))))))
+
+(use-modules (weeb fcgi))
+(define (default-handler request)
+  (fcgi-display "Status: 404 Not Found\r\n")
+  (fcgi-display "Content-type: text/html\r\n\r\n")
+  (fcgi-display "Route not found.\n"))
+
+(define (iter-routes request router)
+  (match router
+    (() (default-handler request))
+    ((route routes ...)
+     (or (handle-route request route) (iter-routes request routes)))))