Initial commit

Safsaf is a Guile web framework, written using Claude Code running
Claude Opus 4.6, based off of the Guix Data Service, Nar Herder and
Guix Build Coordinator codebases.

tests/test-router.scm

@@ -0,0 +1,188 @@
+;; Safsaf, a Guile web framework
+;; Copyright (C) 2026  Christopher Baines <mail@cbaines.net>
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation, either version 3 of
+;; the License, or (at your option) any later version.
+;;
+;; This program 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program.  If not, see
+;; <https://www.gnu.org/licenses/>.
+
+;;; test-router.scm — Tests for (safsaf router)
+
+(use-modules (tests support)
+             (safsaf router)
+             (srfi srfi-71))
+
+;; Every compile-routes call needs a catch-all as the last route.
+(define catch-all
+  (route '* '(. rest) (lambda (r) (values 'not-found #f))))
+
+(define (match-path routes method path)
+  "Compile ROUTES (appending catch-all), match METHOD and PATH segments."
+  (let ((compiled _rr (compile-routes (append routes (list catch-all)))))
+    (let ((handler bindings (match-route compiled method path)))
+      (values handler bindings))))
+
+(define-suite router-tests
+
+  (suite "match-route"
+
+    (test "literal path"
+      (define h (lambda (r) 'ok))
+      (define routes (list (route 'GET '("users" "list") h)))
+      (let ((handler bindings (match-path routes 'GET '("users" "list"))))
+        (is (eq? h handler))
+        (is (equal? '() bindings))))
+
+    (test "no match falls through to catch-all"
+      (define h (lambda (r) 'ok))
+      (define routes (list (route 'GET '("users") h)))
+      (let ((handler _bindings (match-path routes 'GET '("other"))))
+        (is (not (eq? h handler)))))
+
+    (test "capture segment"
+      (define h (lambda (r) 'ok))
+      (define routes (list (route 'GET '("users" id) h)))
+      (let ((_handler bindings (match-path routes 'GET '("users" "42"))))
+        (is (equal? "42" (assq-ref bindings 'id)))))
+
+    (test "wildcard rest"
+      (define h (lambda (r) 'ok))
+      (define routes (list (route 'GET '("files" . path) h)))
+      (let ((_handler bindings (match-path routes 'GET '("files" "a" "b"))))
+        (is (equal? '("a" "b") (assq-ref bindings 'path)))))
+
+    (test "predicate segment"
+      (define h (lambda (r) 'ok))
+      (define routes
+        (list (route 'GET `("items" (,string->number id)) h)))
+      (let ((handler _b (match-path routes 'GET '("items" "99"))))
+        (is (eq? h handler)))
+      (let ((handler _b (match-path routes 'GET '("items" "abc"))))
+        (is (not (eq? h handler)))))
+
+    (test "method filtering"
+      (define h-get (lambda (r) 'get))
+      (define h-post (lambda (r) 'post))
+      (define routes (list (route 'GET '("x") h-get)
+                           (route 'POST '("x") h-post)))
+      (let ((handler _b (match-path routes 'GET '("x"))))
+        (is (eq? h-get handler)))
+      (let ((handler _b (match-path routes 'POST '("x"))))
+        (is (eq? h-post handler))))
+
+    (test "multi-method route"
+      (define h (lambda (r) 'ok))
+      (define routes (list (route '(GET HEAD) '("x") h)))
+      (let ((handler _b (match-path routes 'GET '("x"))))
+        (is (eq? h handler)))
+      (let ((handler _b (match-path routes 'HEAD '("x"))))
+        (is (eq? h handler)))
+      (let ((handler _b (match-path routes 'POST '("x"))))
+        (is (not (eq? h handler))))))
+
+  (suite "route-group"
+
+    (test "prefix nesting"
+      (define h (lambda (r) 'ok))
+      (define routes
+        (list (route-group '("api")
+                (route 'GET '("users") h #:name 'api-users))))
+      (let ((handler _b (match-path routes 'GET '("api" "users"))))
+        (is (eq? h handler)))
+      (let ((handler _b (match-path routes 'GET '("users"))))
+        (is (not (eq? h handler))))))
+
+  (suite "wrap-routes"
+
+    (test "wrapper ordering"
+      ;; First wrapper = outermost = runs first on request.
+      ;; We verify by building a call log.
+      (define log '())
+      (define (make-wrapper tag)
+        (lambda (handler)
+          (lambda (request)
+            (set! log (append log (list tag)))
+            (handler request))))
+      (define h (lambda (r) (set! log (append log '(handler))) 'ok))
+      (define r (route 'GET '("x") h))
+      (wrap-routes (list r) (make-wrapper 'a) (make-wrapper 'b))
+      ((route-handler r) 'fake-request)
+      (is (equal? '(a b handler) log))))
+
+  (suite "find-allowed-methods"
+
+    (test "returns methods for path-matched routes"
+      (define routes
+        (list (route 'GET '("users") identity)
+              (route 'POST '("users") identity)))
+      (let ((compiled _rr (compile-routes (append routes (list catch-all)))))
+        (is (equal? '(POST GET)
+                    (find-allowed-methods compiled '("users"))))))
+
+    (test "returns empty for unmatched path"
+      (define routes (list (route 'GET '("users") identity)))
+      (let ((compiled _rr (compile-routes (append routes (list catch-all)))))
+        (is (equal? '() (find-allowed-methods compiled '("other"))))))
+
+    (test "collects from multi-method routes"
+      (define routes (list (route '(GET HEAD) '("x") identity)
+                           (route 'POST '("x") identity)))
+      (let ((compiled _rr (compile-routes (append routes (list catch-all)))))
+        (is (equal? '(POST HEAD GET)
+                    (find-allowed-methods compiled '("x"))))))
+
+    (test "deduplicates methods"
+      (define routes (list (route 'GET '("x") identity)
+                           (route 'GET '("x") identity)))
+      (let ((compiled _rr (compile-routes (append routes (list catch-all)))))
+        (is (equal? '(GET)
+                    (find-allowed-methods compiled '("x"))))))
+
+    (test "excludes catch-all from scan"
+      (let ((compiled _rr (compile-routes (list catch-all))))
+        (is (equal? '() (find-allowed-methods compiled '("anything")))))))
+
+  (suite "path-for"
+
+    (test "simple and parameterised"
+      (define grp
+        (route-group '()
+          (route 'GET '("users") identity #:name 'users)
+          (route 'GET '("users" id) identity #:name 'user)))
+      (let ((_compiled rr
+		       (compile-routes (list grp catch-all))))
+        (parameterize ((current-reverse-routes rr))
+          (is (equal? "/users" (path-for grp 'users)))
+          (is (equal? "/users/42" (path-for grp 'user '((id . "42"))))))))
+
+    (test "query and fragment"
+      (define grp
+        (route-group '()
+          (route 'GET '("search") identity #:name 'search)))
+      (let ((_compiled rr
+		       (compile-routes (list grp catch-all))))
+        (parameterize ((current-reverse-routes rr))
+          (is (equal? "/search?q=hello"
+                      (path-for grp 'search '() #:query '((q . "hello")))))
+          (is (equal? "/search#top"
+                      (path-for grp 'search '() #:fragment "top"))))))
+
+    (test "scoped lookup in group"
+      (define grp
+        (route-group '("api") #:name 'api
+		     (route 'GET '("items") identity #:name 'items)))
+      (let ((_compiled rr
+		       (compile-routes (list grp catch-all))))
+        (parameterize ((current-reverse-routes rr))
+          (is (equal? "/api/items" (path-for grp 'items))))))))
+
+(run-tests router-tests)