Primordial router

4 files changed, 138 insertions, 9 deletions

diff --git a/tests/router.scm b/tests/router.scm
index 5bdbd51..6f1ddfb 100644
--- a/tests/router.scm
+++ b/tests/router.scm
@@ -1,10 +1,14 @@
 (use-modules (srfi srfi-11)
              (srfi srfi-64)
-             (weeb router))
+             (weeb router)
+             (weeb request)
+             (weeb struct))
 
 ;; Private imports for testing purposes.
 (define uri-template->regexp-string
   (@@ (weeb router) uri-template->regexp-string))
+(define handle-route
+  (@@ (weeb router) handle-route))
 
 (test-runner-current (test-runner-simple))
 
@@ -30,4 +34,46 @@
     (test-equal "/api/([^/]+)/data" re)
     (test-equal '(version) vars)))
 
+(test-group "handle route"
+  (define (handler r id)
+    (list id))
+  (define-router router
+    ("/user/:id:" (GET) handler))
+  (let* ((req (make-struct <request> 'GET "/user/123/" #f #f #f))
+         (route-obj (car router)))
+    (test-equal '("123") (handle-route req route-obj)))
+  (let ((req (make-struct <request> 'POST "/user/123/" #f #f #f))
+        (route-obj (car router)))
+    (test-eqv #f (handle-route req route-obj))))
+
+(test-group "iter-routes 1"
+  (define (static-handler r) "static")
+  (define (api-handler r version) (list version))
+  (define-router router
+    ("/static/"            (GET) static-handler)
+    ("/api/:version:/data" (GET) api-handler))
+  (let ((req (make-struct <request> 'GET "/api/v1/data" #f #f #f)))
+    (test-equal '("v1") (iter-routes req router))))
+
+(test-group "iter-routes 2"
+  (define (handler r org_id user_id) (list org_id user_id))
+  (define-router router
+    ("/org/:org_id:/user/:user_id:/" (GET) handler))
+  (let ((req (make-struct <request> 'GET "/org/42/user/99/" #f #f #f)))
+    (test-equal '("42" "99") (iter-routes req router))))
+
+(test-group "edge cases 1"
+  (define (handler request) "ok")
+  (define-router router
+    ("/health" (GET) handler))
+  (let ((req (make-struct <request> 'GET "/health" #f #f #f)))
+    (test-equal "ok" (iter-routes req router))))
+
+(test-group "edge cases 2"
+  (define (handler request) "home")
+  (define-router router
+    ("/" (GET) handler))
+  (let ((req (make-struct <request> 'GET "/" #f #f #f)))
+    (test-equal "home" (iter-routes req router))))
+
 (test-end)
diff --git a/weeb/main.scm b/weeb/main.scm
index 2fc6df1..4c7e69f 100644
--- a/weeb/main.scm
+++ b/weeb/main.scm
@@ -20,16 +20,18 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11) ;; Temporary, probably
   #:use-module (weeb fcgi)
   #:use-module (weeb request)
+  #:use-module (weeb router)
   #:use-module (weeb struct)
   #:export (weeb main))
 
 (define (receive-request)
   (define string->method
     (match-lambda
-      (("GET"  'GET)
-       ("POST" 'POST))))
+      ("GET"  'GET)
+      ("POST" 'POST)))
   ;; According to RFC 9110, header names must be treated as case-insensitive.
   (define headers
     (filter-map
@@ -44,13 +46,26 @@
                ,(match:substring match-object 2))
              #f)))
      (environ)))
-  (let* ((method (getenv "REQUEST_METHOD"))
+  (let* ((method (string->method (getenv "REQUEST_METHOD")))
          (uri    (getenv "REQUEST_URI")))
     (make-struct <request> method uri '() headers (fcgi-read))))
 
+(define (show-headers request)
+  ;; TODO: Return a response object.
+  (with-accessors (request headers)
+    (fcgi-display "Content-type: text/html\r\n\r\n")
+    (fcgi-display (format #f "~a" headers))))
+
+(define (show-message request message)
+  (fcgi-display (format #f "~a" message)))
+
+(define-router router
+  ("/headers"        (GET) show-headers)
+  ("/echo/:message:" (GET) show-message))
+
 (define (run-server)
   (while (zero? (fcgi-accept))
     (let ((request (receive-request)))
-      (with-accessors (request method uri headers body)
-        (fcgi-display "Content-type: text/html\r\n\r\n")
-        (fcgi-display (format #f "~a" headers))))))
+      (iter-routes request router))))
+
+(run-server)
diff --git a/weeb/request.scm b/weeb/request.scm
new file mode 100644
index 0000000..42cd933
--- /dev/null
+++ b/weeb/request.scm
@@ -0,0 +1,24 @@
+;;; Weeb --- Web microframework for GNU Guile
+;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This file is part of Weeb.
+;;;
+;;; Weeb is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Weeb is distributed in the hope that it will be useful, but WITHOUT
+;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+;;; Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (weeb request)
+  #:use-module (weeb struct)
+  #:export (<request>))
+
+(define-struct <request>
+  method uri parameters headers body)
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)))))