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/CLAUDE.md

@@ -0,0 +1,73 @@
+# Testing
+
+## Framework
+
+Tests use a minimal SRFI-269 implementation in `(tests support)`.  Three
+primitives — `is`, `test`, `suite` — build first-class test entities and
+deliver them to a pluggable runner.  Definition is separated from execution.
+
+## Running tests
+
+All tests (via Automake):
+
+    make check
+
+Single file:
+
+    ./pre-inst-env guile tests/test-router.scm
+
+## Writing tests
+
+```scheme
+(use-modules (tests support)
+             (safsaf router))        ; module under test
+
+(define-suite router-tests
+  (suite "route construction"
+    (test "creates route with method and pattern"
+      (let ((r (route 'GET '("users") identity)))
+        (is (route? r))
+        (is (eq? 'GET (route-method r))))))
+
+  (suite "matching"
+    (test "exact path match"
+      ...)))
+
+(run-tests router-tests)
+```
+
+Key points:
+
+- `(is expr)` — assert expr is truthy.  Returns the value on success.
+- `(is (pred arg ...))` — predicate form; on failure shows evaluated args.
+- `(test "desc" body ...)` — a single test case with one or more assertions.
+- `(suite "desc" body ...)` — group tests and nested suites.
+- `(define-suite name body ...)` — bind a suite-thunk to a variable.
+- `(run-tests thunk)` — run with the simple runner, print summary, exit.
+- Tests should be self-contained: don't depend on ordering or side effects
+  from other tests.
+- Use `define` inside `test` bodies for local setup.
+
+## Synthetic requests
+
+Many tests need Guile `<request>` objects without a real HTTP server.
+Build them with `build-request` from `(web request)`:
+
+```scheme
+(use-modules (web request) (web uri))
+
+(define* (make-request method path #:optional (headers '()))
+  (build-request (build-uri 'http #:host "localhost" #:path path)
+                 #:method method
+                 #:headers headers))
+```
+
+Handler signature is `(request body-port) → (values response body)`.  When
+calling handlers or wrapped handlers in tests, pass `#f` as the body-port:
+
+```scheme
+(let ((resp body (wrapped (make-request 'GET "/" '()) #f)))
+  (is (= 200 (response-code resp))))
+```
+
+For handlers that read `current-route-params`, `parameterize` it directly.

tests/support.scm

@@ -0,0 +1,243 @@
+;; 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/>.
+
+(define-module (tests support)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-1)
+  #:export (is
+            test
+            suite
+            suite-thunk
+            define-suite
+            test-runner*
+            test?
+            suite?
+            suite-thunk?
+            run-tests))
+
+;;;
+;;; Minimal SRFI-269 implementation for Guile.
+;;;
+;;; Three definition primitives — is, test, suite — construct first-class
+;;; entities (alists) and deliver them to a pluggable test runner via
+;;; message passing.  Definition is separated from execution: the runner
+;;; decides when and how to run things.
+;;;
+
+;;; --- Parameter ---
+
+(define test-runner* (make-parameter #f))
+
+;;; --- Predicates ---
+
+(define (test? obj)
+  (and (pair? obj)
+       (assq 'test/body-thunk obj)
+       (assq 'test/description obj)
+       #t))
+
+(define (suite? obj)
+  (and (pair? obj)
+       (assq 'suite/body-thunk obj)
+       (assq 'suite/description obj)
+       #t))
+
+(define (suite-thunk? obj)
+  (procedure? obj))
+
+;;; --- is ---
+
+(define-syntax is
+  (lambda (x)
+    (syntax-case x ()
+      ;; Predicate form: (is (pred arg ...))
+      ((_ (pred arg ...))
+       (with-syntax ((src (datum->syntax x (syntax-source x))))
+         #'(%run-assert
+            (lambda () (pred arg ...))
+            '(pred arg ...)
+            'src
+            (lambda () (list arg ...)))))
+      ;; Simple form: (is expr)
+      ((_ expr)
+       (with-syntax ((src (datum->syntax x (syntax-source x))))
+         #'(%run-assert
+            (lambda () expr)
+            'expr
+            'src
+            #f))))))
+
+(define (%run-assert body-thunk body-datum source args-thunk)
+  (let* ((entity `((assert/body-thunk . ,body-thunk)
+                   (assert/body . ,body-datum)
+                   (assert/location . ,source)
+                   ,@(if args-thunk
+                         `((assert/args-thunk . ,args-thunk))
+                         '()))))
+    ((test-runner*)
+     `((type . runner/run-assert)
+       (assert . ,entity)))))
+
+;;; --- test ---
+
+(define-syntax test
+  (syntax-rules (quote)
+    ((_ desc (quote metadata) meta body ...)
+     (%load-test desc 'meta (lambda () body ... (values))))
+    ((_ desc body ...)
+     (%load-test desc '() (lambda () body ... (values))))))
+
+(define (%load-test description metadata body-thunk)
+  ((test-runner*)
+   `((type . runner/load-test)
+     (test . ((test/body-thunk . ,body-thunk)
+              (test/description . ,description)
+              (test/metadata . ,metadata))))))
+
+;;; --- suite ---
+
+(define-syntax suite
+  (syntax-rules (quote)
+    ((_ desc (quote metadata) meta body ...)
+     (%load-suite desc 'meta (lambda () body ... (values))))
+    ((_ desc body ...)
+     (%load-suite desc '() (lambda () body ... (values))))))
+
+(define (%load-suite description metadata body-thunk)
+  ((test-runner*)
+   `((type . runner/load-suite)
+     (suite . ((suite/body-thunk . ,body-thunk)
+               (suite/description . ,description)
+               (suite/metadata . ,metadata))))))
+
+;;; --- suite-thunk ---
+
+(define-syntax suite-thunk
+  (syntax-rules (quote)
+    ((_ desc (quote metadata) meta body ...)
+     (lambda ()
+       (%load-suite desc 'meta (lambda () body ... (values)))))
+    ((_ desc body ...)
+     (lambda ()
+       (%load-suite desc '() (lambda () body ... (values)))))))
+
+;;; --- define-suite ---
+
+(define-syntax define-suite
+  (syntax-rules (quote)
+    ((_ name (quote metadata) meta body ...)
+     (define name
+       (suite-thunk (symbol->string 'name) (quote metadata) meta body ...)))
+    ((_ name body ...)
+     (define name
+       (suite-thunk (symbol->string 'name) body ...)))))
+
+
+;;;
+;;; Simple immediate-execution test runner.
+;;;
+
+(define %depth 0)
+(define %pass-count 0)
+(define %fail-count 0)
+(define %error-count 0)
+(define %test-failed? #f)
+
+(define (indent)
+  (make-string (* 2 %depth) #\space))
+
+(define (format-location loc)
+  "Return a string like \"file.scm:42\" from a source location alist,
+or #f if location info is unavailable."
+  (and loc
+       (let ((file (assq-ref loc 'filename))
+             (line (assq-ref loc 'line)))
+         (and file line
+              (format #f "~a:~a" file (+ line 1))))))
+
+(define (simple-test-runner message)
+  (let ((type (assq-ref message 'type)))
+    (case type
+
+      ((runner/load-suite)
+       (let* ((s (assq-ref message 'suite))
+              (desc (assq-ref s 'suite/description))
+              (body (assq-ref s 'suite/body-thunk)))
+         (format #t "~a~a~%" (indent) desc)
+         (set! %depth (+ %depth 1))
+         (body)
+         (set! %depth (- %depth 1))))
+
+      ((runner/load-test)
+       (let* ((t (assq-ref message 'test))
+              (desc (assq-ref t 'test/description))
+              (body (assq-ref t 'test/body-thunk)))
+         (set! %test-failed? #f)
+         (with-exception-handler
+             (lambda (exn)
+               (set! %error-count (+ %error-count 1))
+               (format #t "~aERROR ~a~%" (indent) desc)
+               (format #t "~a  ~a~%" (indent) exn))
+             (lambda ()
+               (body)
+               (if %test-failed?
+                   (begin
+                     (set! %fail-count (+ %fail-count 1))
+                     (format #t "~aFAIL  ~a~%" (indent) desc))
+                   (begin
+                     (set! %pass-count (+ %pass-count 1))
+                     (format #t "~aok    ~a~%" (indent) desc))))
+           #:unwind? #t)))
+
+      ((runner/run-assert)
+       (let* ((a (assq-ref message 'assert))
+              (body-thunk (assq-ref a 'assert/body-thunk))
+              (body-datum (assq-ref a 'assert/body))
+              (loc (assq-ref a 'assert/location)))
+         (let ((result (body-thunk)))
+           (unless result
+             (set! %test-failed? #t)
+             (format #t "~a  FAIL: ~s" (indent) body-datum)
+             (let ((loc-str (format-location loc)))
+               (when loc-str
+                 (format #t " at ~a" loc-str)))
+             (newline)
+             ;; Show evaluated arguments for predicate assertions.
+             (let ((args-thunk (assq-ref a 'assert/args-thunk)))
+               (when args-thunk
+                 (with-exception-handler
+                     (lambda (_) #f)
+                     (lambda ()
+                       (let ((args (args-thunk)))
+			 (format #t "~a    args: ~s~%" (indent) args)))
+                   #:unwind? #t))))
+           result))))))
+
+(define (run-tests thunk)
+  "Set up the simple test runner, call THUNK (typically a suite-thunk),
+print a summary, and exit with 0 on success or 1 on failure."
+  (set! %depth 0)
+  (set! %pass-count 0)
+  (set! %fail-count 0)
+  (set! %error-count 0)
+  (parameterize ((test-runner* simple-test-runner))
+    (thunk))
+  (newline)
+  (let ((total (+ %pass-count %fail-count %error-count)))
+    (format #t "~a passed, ~a failed, ~a errors (of ~a)~%"
+            %pass-count %fail-count %error-count total)
+    (exit (if (and (zero? %fail-count) (zero? %error-count)) 0 1))))

tests/test-csrf-validation.scm

@@ -0,0 +1,65 @@
+;; 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-csrf-validation.scm — Tests for CSRF integration in (safsaf params)
+;;;                             and (safsaf handler-wrappers csrf)
+
+(use-modules (tests support)
+             (safsaf params)
+             (safsaf handler-wrappers csrf))
+
+(define-suite csrf-validation-tests
+
+  (suite "csrf"
+
+    (test "csrf-token-field produces sxml"
+      (parameterize ((current-csrf-token "abc123"))
+        (let ((field (csrf-token-field)))
+          (is (pair? field))
+          (is (eq? 'input (car field))))))
+
+    (test "parse-form-params checks csrf"
+      (parameterize ((current-csrf-token "tok123"))
+        (let ((result (parse-form-params '()
+				     '(("csrf-token" . "tok123")))))
+          (is (not (any-invalid-params? result))))
+        (let ((result (parse-form-params '()
+				     '(("csrf-token" . "wrong")))))
+          (is (any-invalid-params? result)))))
+
+    (test "parse-form-params csrf missing"
+      (parameterize ((current-csrf-token "tok123"))
+        (let ((result (parse-form-params '() '())))
+          (is (any-invalid-params? result)))))
+
+    (test "parse-form-params validates other fields too"
+      (parameterize ((current-csrf-token "tok123"))
+        (let ((result (parse-form-params
+                        `((name ,as-string #:required))
+                        '(("csrf-token" . "tok123") ("name" . "Alice")))))
+          (is (not (any-invalid-params? result)))
+          (is (equal? "Alice" (assq-ref result 'name))))))
+
+    (test "parse-form-params field errors with valid csrf"
+      (parameterize ((current-csrf-token "tok123"))
+        (let ((result (parse-form-params
+                        `((name ,as-string #:required))
+                        '(("csrf-token" . "tok123")))))
+          (is (any-invalid-params? result))
+          (is (invalid-param? (assq-ref result 'name))))))))
+
+(run-tests csrf-validation-tests)

tests/test-exceptions.scm

@@ -0,0 +1,146 @@
+;; 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-exceptions.scm — Tests for (safsaf handler-wrappers exceptions)
+
+(use-modules (tests support)
+             (safsaf handler-wrappers exceptions)
+             (srfi srfi-71)
+             (web request)
+             (web response)
+             (web uri))
+
+(define (make-request method path headers)
+  (build-request (build-uri 'http #:host "localhost" #:path path)
+                 #:method method
+                 #:headers headers))
+
+(define (failing-handler request body-port)
+  (error "test explosion"))
+
+(define (ok-handler request body-port)
+  (values (build-response #:code 200) "ok"))
+
+(define html-request
+  (make-request 'GET "/" '((accept . ((text/html))))))
+
+(define json-request
+  (make-request 'GET "/" '((accept . ((application/json))))))
+
+(define-suite exceptions-tests
+
+  (suite "passthrough"
+
+    (test "successful handler passes through unchanged"
+      (define wrapped (exceptions-handler-wrapper ok-handler))
+      (let ((resp body (wrapped html-request #f)))
+        (is (= 200 (response-code resp)))
+        (is (equal? "ok" body)))))
+
+  (suite "production mode"
+
+    (test "returns 500 for HTML client"
+      (define wrapped (exceptions-handler-wrapper failing-handler))
+      (let ((resp body (wrapped html-request #f)))
+        (is (= 500 (response-code resp)))
+        ;; Body is a streaming procedure from html-response.
+        (is (procedure? body))))
+
+    (test "returns 500 JSON for JSON client"
+      (define wrapped (exceptions-handler-wrapper failing-handler))
+      (let ((resp body (wrapped json-request #f)))
+        (is (= 500 (response-code resp)))
+        (is (string? body))
+        ;; Should contain error key but not backtrace.
+        (is (string-contains body "Internal Server Error"))
+        (is (not (string-contains body "test explosion"))))))
+
+  (suite "dev mode"
+
+    (test "returns 500 with backtrace for HTML client"
+      (define wrapped (exceptions-handler-wrapper failing-handler
+                                                   #:dev? #t))
+      (let ((resp body (wrapped html-request #f)))
+        (is (= 500 (response-code resp)))
+        ;; Body is a streaming procedure containing backtrace.
+        (is (procedure? body))))
+
+    (test "returns 500 JSON with backtrace for JSON client"
+      (define wrapped (exceptions-handler-wrapper failing-handler
+                                                   #:dev? #t))
+      (let ((resp body (wrapped json-request #f)))
+        (is (= 500 (response-code resp)))
+        (is (string? body))
+        (is (string-contains body "backtrace"))
+        (is (string-contains body "test explosion")))))
+
+  (suite "custom renderers"
+
+    (test "render-error overrides everything"
+      (define wrapped
+        (exceptions-handler-wrapper
+         failing-handler
+         #:render-error
+         (lambda (request code message bt dev?)
+           (values (build-response #:code code) "custom error"))))
+      (let ((resp body (wrapped html-request #f)))
+        (is (= 500 (response-code resp)))
+        (is (equal? "custom error" body))))
+
+    (test "render-html overrides only HTML"
+      (define wrapped
+        (exceptions-handler-wrapper
+         failing-handler
+         #:render-html
+         (lambda (request code message bt dev?)
+           (values (build-response #:code code
+                                   #:headers '((content-type text/html)))
+                   "custom html"))))
+      ;; HTML request gets custom renderer.
+      (let ((resp body (wrapped html-request #f)))
+        (is (equal? "custom html" body)))
+      ;; JSON request gets default JSON renderer.
+      (let ((resp body (wrapped json-request #f)))
+        (is (string? body))
+        (is (string-contains body "Internal Server Error"))))
+
+    (test "render-json overrides only JSON"
+      (define wrapped
+        (exceptions-handler-wrapper
+         failing-handler
+         #:render-json
+         (lambda (request code message bt dev?)
+           (values (build-response #:code code
+                                   #:headers '((content-type application/json)))
+                   "{\"err\":\"custom\"}"))))
+      ;; JSON request gets custom renderer.
+      (let ((resp body (wrapped json-request #f)))
+        (is (equal? "{\"err\":\"custom\"}" body)))
+      ;; HTML request gets default HTML renderer.
+      (let ((resp body (wrapped html-request #f)))
+        (is (procedure? body)))))
+
+  (suite "make-exceptions-handler-wrapper"
+
+    (test "factory returns a working wrapper"
+      (define wrapper (make-exceptions-handler-wrapper #:dev? #t))
+      (define wrapped (wrapper failing-handler))
+      (let ((resp body (wrapped json-request #f)))
+        (is (= 500 (response-code resp)))
+        (is (string-contains body "test explosion"))))))
+
+(run-tests exceptions-tests)

tests/test-handler-wrappers.scm

@@ -0,0 +1,274 @@
+;; 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-handler-wrappers.scm — Tests for standalone handler wrappers
+
+(use-modules (tests support)
+             (safsaf handler-wrappers security-headers)
+             (safsaf handler-wrappers cors)
+             (safsaf handler-wrappers max-body-size)
+             (safsaf handler-wrappers sessions)
+             (safsaf handler-wrappers trailing-slash)
+             (srfi srfi-71)
+             (web request)
+             (web response)
+             (web uri)
+             (webutils cookie))  ; registers Cookie header parser
+
+;; A handler that returns a plain 200 response.
+(define (ok-handler request body-port)
+  (values (build-response #:code 200) "ok"))
+
+(define* (make-request method path headers #:key (validate? #t))
+  (build-request (build-uri 'http #:host "localhost" #:path path)
+                 #:method method
+                 #:headers headers
+                 #:validate-headers? validate?))
+
+(define-suite handler-wrappers-tests
+
+  (suite "security-headers"
+
+    (test "adds default headers"
+      (define wrapped (security-headers-handler-wrapper ok-handler))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (equal? "nosniff"
+                    (assq-ref (response-headers resp)
+                              'x-content-type-options)))
+        (is (equal? "DENY"
+                    (assq-ref (response-headers resp)
+                              'x-frame-options)))))
+
+    (test "disabling a header with #f"
+      (define wrapped
+        (security-headers-handler-wrapper ok-handler
+                                          #:frame-options #f))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (not (assq-ref (response-headers resp)
+                           'x-frame-options)))))
+
+    (test "content-security-policy header"
+      (define wrapped
+        (security-headers-handler-wrapper ok-handler
+          #:content-security-policy "default-src 'self'; script-src 'self'"))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (equal? "default-src 'self'; script-src 'self'"
+                    (assq-ref (response-headers resp)
+                              'content-security-policy)))))
+
+    (test "content-security-policy-report-only header"
+      (define wrapped
+        (security-headers-handler-wrapper ok-handler
+          #:content-security-policy-report-only "default-src 'self'"))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (equal? "default-src 'self'"
+                    (assq-ref (response-headers resp)
+                              'content-security-policy-report-only)))
+        ;; Enforcing header should not be set.
+        (is (not (assq-ref (response-headers resp)
+                           'content-security-policy))))))
+
+  (suite "cors"
+
+    (test "no origin header passes through"
+      (define wrapped (cors-handler-wrapper ok-handler))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (= 200 (response-code resp)))
+        (is (not (assq-ref (response-headers resp)
+                           'access-control-allow-origin)))))
+
+    (test "preflight returns 204"
+      (define wrapped (cors-handler-wrapper ok-handler))
+      (let ((resp _body
+                  (wrapped (make-request 'OPTIONS "/"
+                                         '((origin . "http://example.com")))
+                           #f)))
+        (is (= 204 (response-code resp)))
+        (is (equal? "*" (assq-ref (response-headers resp)
+                                  'access-control-allow-origin)))))
+
+    (test "normal request with origin adds cors headers"
+      (define wrapped (cors-handler-wrapper ok-handler))
+      (let ((resp _body
+                  (wrapped (make-request 'GET "/"
+                                         '((origin . "http://example.com")))
+                           #f)))
+        (is (= 200 (response-code resp)))
+        (is (assq-ref (response-headers resp)
+                      'access-control-allow-origin))))
+
+    (test "disallowed origin gets no cors headers"
+      (define wrapped
+        (cors-handler-wrapper ok-handler
+                              #:origins '("http://allowed.com")))
+      (let ((resp _body
+                  (wrapped (make-request 'GET "/"
+                                         '((origin . "http://evil.com")))
+                           #f)))
+        (is (= 200 (response-code resp)))
+        (is (not (assq-ref (response-headers resp)
+                           'access-control-allow-origin))))))
+
+  (suite "sessions"
+
+    (test "round-trip set and read"
+      (define mgr (make-session-config "test-secret-key-1234"))
+      (define wrapper (make-session-handler-wrapper mgr))
+      ;; Set a session and extract the cookie name=value.
+      (let* ((cookie-hdr (session-set mgr '((user . "alice"))))
+             ;; cdr is (name value attrs...) — build parsed cookie alist
+             (cookie-name (car (cdr cookie-hdr)))
+             (cookie-value (cadr (cdr cookie-hdr)))
+             (cookie-alist (list (cons cookie-name cookie-value))))
+        ;; Now make a request with that cookie and read it back.
+        (define reading-handler
+          (lambda (request body-port) (values (build-response #:code 200)
+                                    (current-session))))
+        (define wrapped (wrapper reading-handler))
+        (let ((_resp body
+                     (wrapped (make-request 'GET "/"
+                                            `((cookie . ,cookie-alist))
+                                            #:validate? #f)
+                              #f)))
+          (is (pair? body))
+          (is (equal? "alice" (assq-ref body 'user))))))
+
+    (test "missing session yields #f"
+      (define mgr (make-session-config "test-secret-key-1234"))
+      (define reading-handler
+        (lambda (request body-port) (values (build-response #:code 200)
+                                  (current-session))))
+      (define wrapped ((make-session-handler-wrapper mgr) reading-handler))
+      (let ((_resp body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (not body)))))
+
+  (suite "max-body-size"
+
+    (test "allows request under limit"
+      (define wrapper (make-max-body-size-handler-wrapper 1024))
+      (define wrapped (wrapper ok-handler))
+      (let ((resp _body
+                  (wrapped (make-request 'GET "/"
+                                         '((content-length . 512)))
+                           #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "rejects request over limit with 413"
+      (define wrapper (make-max-body-size-handler-wrapper 1024))
+      (define wrapped (wrapper ok-handler))
+      (let ((resp _body
+                  (wrapped (make-request 'GET "/"
+                                         '((content-length . 2048)))
+                           #f)))
+        (is (= 413 (response-code resp)))))
+
+    (test "passes through when no content-length"
+      (define wrapper (make-max-body-size-handler-wrapper 1024))
+      (define wrapped (wrapper ok-handler))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "custom 413 handler"
+      (define wrapper
+        (make-max-body-size-handler-wrapper
+         100
+         #:handler-413
+         (lambda (request body-port)
+           (values (build-response #:code 413) "too big"))))
+      (define wrapped (wrapper ok-handler))
+      (let ((resp body
+                  (wrapped (make-request 'GET "/"
+                                         '((content-length . 200)))
+                           #f)))
+        (is (= 413 (response-code resp)))
+        (is (equal? "too big" body)))))
+
+  (suite "trailing-slash"
+
+    (test "strip mode redirects trailing slash"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'strip))
+      (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f)))
+        (is (= 301 (response-code resp)))
+        (is (equal? "/foo"
+                    (uri->string
+                     (assq-ref (response-headers resp) 'location))))))
+
+    (test "strip mode passes through without trailing slash"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'strip))
+      (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "append mode redirects missing trailing slash"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'append))
+      (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f)))
+        (is (= 301 (response-code resp)))
+        (is (equal? "/foo/"
+                    (uri->string
+                     (assq-ref (response-headers resp) 'location))))))
+
+    (test "append mode passes through with trailing slash"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'append))
+      (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "root path passes through in strip mode"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'strip))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "root path passes through in append mode"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'append))
+      (let ((resp _body (wrapped (make-request 'GET "/" '()) #f)))
+        (is (= 200 (response-code resp)))))
+
+    (test "preserves query string"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler #:mode 'strip))
+      (let* ((req (build-request
+                   (build-uri 'http #:host "localhost"
+                              #:path "/foo/" #:query "bar=1")
+                   #:method 'GET #:headers '()))
+             (resp _body (wrapped req #f)))
+        (is (= 301 (response-code resp)))
+        (is (equal? "/foo?bar=1"
+                    (uri->string
+                     (assq-ref (response-headers resp) 'location))))))
+
+    (test "custom status code"
+      (define wrapped
+        (trailing-slash-handler-wrapper ok-handler
+                                        #:mode 'strip #:code 302))
+      (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f)))
+        (is (= 302 (response-code resp)))))
+
+    (test "make-trailing-slash-handler-wrapper factory"
+      (define wrapper
+        (make-trailing-slash-handler-wrapper #:mode 'append #:code 308))
+      (define wrapped (wrapper ok-handler))
+      (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f)))
+        (is (= 308 (response-code resp)))
+        (is (equal? "/foo/"
+                    (uri->string
+                     (assq-ref (response-headers resp) 'location))))))))
+
+(run-tests handler-wrappers-tests)

tests/test-integration.scm

@@ -0,0 +1,273 @@
+;; 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-integration.scm — Full-stack integration tests
+;;;
+;;; Starts a real HTTP server inside run-fibers and makes requests
+;;; via a thread pool (Guile's (web client) uses blocking I/O that
+;;; does not cooperate with the fibers scheduler).
+
+(use-modules (tests support)
+             (fibers)
+             (knots web-server)
+             (knots thread-pool)
+             (safsaf)
+             (safsaf router)
+             (safsaf response-helpers)
+             (safsaf utils)
+             (srfi srfi-71)
+             (rnrs bytevectors)
+             (web client)
+             (web request)
+             (web response)
+             (web uri))
+
+(define test-port 8399)
+(define test-base (string-append "http://127.0.0.1:"
+                                 (number->string test-port)))
+
+;;;
+;;; Test handlers
+;;;
+
+(define (echo-form-handler request body-port)
+  "Parse a URL-encoded form body and echo each field as key=value lines."
+  (let ((fields (parse-form-body request body-port)))
+    (text-response
+     (string-join (map (lambda (pair)
+                         (string-append (car pair) "=" (cdr pair)))
+                       fields)
+                  "\n"))))
+
+(define (echo-multipart-handler request body-port)
+  "Parse a multipart body, extract text fields, echo as key=value lines."
+  (let* ((parts (parse-multipart-body request body-port))
+         (fields (multipart-text-fields parts)))
+    (text-response
+     (string-join (map (lambda (pair)
+                         (string-append (car pair) "=" (cdr pair)))
+                       fields)
+                  "\n"))))
+
+(define (greet-handler request body-port)
+  (text-response "hello"))
+
+(define (catch-all-handler request body-port)
+  (not-found-response))
+
+;;;
+;;; Route table
+;;;
+
+(define test-routes
+  (list
+   (route 'GET '("greet") greet-handler)
+   (route 'POST '("form") echo-form-handler)
+   (route 'POST '("multipart") echo-multipart-handler)
+   (route '* '(. rest) catch-all-handler)))
+
+;;;
+;;; Multipart body construction
+;;;
+
+(define (make-multipart-body boundary fields)
+  "Build a multipart/form-data body bytevector from FIELDS,
+an alist of (name . value) string pairs."
+  (let ((parts
+         (string-join
+          (map (lambda (pair)
+                 (string-append
+                  "--" boundary "\r\n"
+                  "Content-Disposition: form-data; name=\""
+                  (car pair) "\"\r\n"
+                  "\r\n"
+                  (cdr pair)))
+               fields)
+          "\r\n")))
+    (string->utf8
+     (string-append parts "\r\n"
+                    "--" boundary "--\r\n"))))
+
+;;;
+;;; Test runner
+;;;
+
+(define %pass 0)
+(define %fail 0)
+
+(define (check desc ok?)
+  (if ok?
+      (begin
+        (set! %pass (1+ %pass))
+        (format #t "  ok    ~a~%" desc))
+      (begin
+        (set! %fail (1+ %fail))
+        (format #t "  FAIL  ~a~%" desc)))
+  (force-output))
+
+;;; HTTP client helper — runs requests on a thread pool because
+;;; Guile's (web client) uses blocking I/O incompatible with fibers.
+(define http-pool (make-fixed-size-thread-pool 1))
+
+(define (test-post path headers body)
+  "POST to the test server.  Returns (values response body-string)."
+  (call-with-thread
+   http-pool
+   (lambda ()
+     (http-post (string-append test-base path)
+                #:headers headers
+                #:body body))))
+
+(define (test-get path)
+  "GET from the test server.  Returns (values response body-string)."
+  (call-with-thread
+   http-pool
+   (lambda ()
+     (http-get (string-append test-base path)))))
+
+(define (test-head path)
+  "HEAD to the test server.  Returns (values response body-string)."
+  (call-with-thread
+   http-pool
+   (lambda ()
+     (http-head (string-append test-base path)))))
+
+(define (test-delete path)
+  "DELETE to the test server.  Returns (values response body-string)."
+  (call-with-thread
+   http-pool
+   (lambda ()
+     (http-delete (string-append test-base path)))))
+
+;;;
+;;; Run everything inside a single run-fibers.
+;;;
+
+(run-fibers
+ (lambda ()
+   (run-safsaf test-routes
+               #:host "127.0.0.1"
+               #:port test-port)
+
+   (sleep 1)
+
+   (with-exception-handler
+       (lambda (exn)
+         (format (current-error-port) "~%Test error: ~a~%" exn)
+         (force-output (current-error-port))
+         (primitive-_exit 1))
+       (lambda ()
+
+         (format #t "parse-form-body via HTTP~%")
+
+         ;; Test 1: basic url-encoded fields
+         (let ((resp body
+                     (test-post "/form"
+                       '((content-type
+                          . (application/x-www-form-urlencoded)))
+                       "name=Alice&age=30")))
+           (check "basic url-encoded fields"
+                  (and (= 200 (response-code resp))
+                       (string-contains body "name=Alice")
+                       (string-contains body "age=30"))))
+
+         ;; Test 2: plus signs decoded as spaces
+         (let ((resp body
+                     (test-post "/form"
+                       '((content-type
+                          . (application/x-www-form-urlencoded)))
+                       "greeting=hello+world")))
+           (check "plus signs decoded as spaces"
+                  (and (= 200 (response-code resp))
+                       (string-contains body "greeting=hello world"))))
+
+         ;; Test 3: percent-encoded values
+         (let ((resp body
+                     (test-post "/form"
+                       '((content-type
+                          . (application/x-www-form-urlencoded)))
+                       "msg=caf%C3%A9")))
+           (check "percent-encoded values"
+                  (and (= 200 (response-code resp))
+                       (string-contains body "msg=café"))))
+
+         (format #t "~%parse-multipart-body via HTTP~%")
+
+         ;; Test 4: basic multipart text fields
+         (let* ((boundary "----TestBoundary12345")
+                (body-bv (make-multipart-body boundary
+                           '(("title" . "Hello")
+                             ("body"  . "World")))))
+           (let ((resp body
+                       (test-post "/multipart"
+                         `((content-type
+                            . (multipart/form-data
+                               (boundary . ,boundary))))
+                         body-bv)))
+             (check "basic multipart text fields"
+                    (and (= 200 (response-code resp))
+                         (string-contains body "title=Hello")
+                         (string-contains body "body=World")))))
+
+         (format #t "~%405 Method Not Allowed~%")
+
+         ;; Test 5: POST to a GET-only route returns 405
+         (let ((resp body (test-post "/greet" '() "")))
+           (check "POST to GET-only route returns 405"
+                  (= 405 (response-code resp)))
+           (check "405 response includes Allow header with GET and HEAD"
+                  (let ((allowed (assq-ref (response-headers resp)
+                                           'allow)))
+                    (and (memq 'GET allowed)
+                         (memq 'HEAD allowed)))))
+
+         ;; Test 6: DELETE to a GET-only route returns 405
+         (let ((resp _body (test-delete "/greet")))
+           (check "DELETE to GET-only route returns 405"
+                  (= 405 (response-code resp))))
+
+         (format #t "~%Automatic HEAD handling~%")
+
+         ;; Test 7: HEAD to a GET route returns 200 with empty body
+         (let ((resp body (test-head "/greet")))
+           (check "HEAD to GET route returns 200"
+                  (= 200 (response-code resp)))
+           (check "HEAD response has empty body"
+                  (or (not body)
+                      (and (string? body) (string-null? body)))))
+
+         ;; Test 8: HEAD to a non-existent path falls through to catch-all
+         (let ((resp _body (test-head "/no-such-path")))
+           (check "HEAD to unknown path returns 404"
+                  (= 404 (response-code resp))))
+
+         ;; Test 9: GET to the greet route works normally
+         (let ((resp body (test-get "/greet")))
+           (check "GET to greet route returns 200"
+                  (= 200 (response-code resp)))
+           (check "GET to greet route returns body"
+                  (string-contains body "hello")))
+
+         ;; Summary and exit.
+         (newline)
+         (let ((total (+ %pass %fail)))
+           (format #t "~a passed, ~a failed (of ~a)~%"
+                   %pass %fail total)
+           (force-output)
+           (primitive-_exit (if (zero? %fail) 0 1))))
+     #:unwind? #t))
+ #:drain? #f)

tests/test-params.scm

@@ -0,0 +1,307 @@
+;; 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/>.
+
+(use-modules (tests support)
+             (safsaf params)
+             (safsaf handler-wrappers csrf))
+
+(define-suite params-tests
+
+  (suite "processors"
+
+    (test "as-string passes through"
+      (is (equal? "hello" (as-string "hello"))))
+
+    (test "as-integer parses integers"
+      (is (equal? 42 (as-integer "42")))
+      (is (equal? -3 (as-integer "-3")))
+      (is (equal? 0 (as-integer "0"))))
+
+    (test "as-integer rejects non-integers"
+      (is (invalid-param? (as-integer "3.14")))
+      (is (invalid-param? (as-integer "abc")))
+      (is (invalid-param? (as-integer ""))))
+
+    (test "as-number parses numbers"
+      (is (equal? 42 (as-number "42")))
+      (is (equal? 3.14 (as-number "3.14")))
+      (is (equal? -1 (as-number "-1"))))
+
+    (test "as-number rejects non-numbers"
+      (is (invalid-param? (as-number "abc")))
+      (is (invalid-param? (as-number ""))))
+
+    (test "as-checkbox"
+      (is (eq? #t (as-checkbox "on")))
+      (is (eq? #f (as-checkbox "off")))
+      (is (eq? #f (as-checkbox ""))))
+
+    (test "as-one-of accepts valid choices"
+      (define proc (as-one-of '("red" "green" "blue")))
+      (is (equal? "red" (proc "red")))
+      (is (equal? "blue" (proc "blue"))))
+
+    (test "as-one-of rejects invalid choices"
+      (define proc (as-one-of '("red" "green" "blue")))
+      (is (invalid-param? (proc "yellow"))))
+
+    (test "as-one-of custom message"
+      (define proc (as-one-of '("a") #:message "nope"))
+      (is (equal? "nope" (invalid-param-message (proc "z")))))
+
+    (test "as-matching accepts matching values"
+      (define proc (as-matching "^[0-9]+$"))
+      (is (equal? "123" (proc "123"))))
+
+    (test "as-matching rejects non-matching values"
+      (define proc (as-matching "^[0-9]+$"))
+      (is (invalid-param? (proc "abc"))))
+
+    (test "as-predicate"
+      (define proc (as-predicate (lambda (s) (> (string-length s) 3))))
+      (is (equal? "hello" (proc "hello")))
+      (is (invalid-param? (proc "hi")))))
+
+  (suite "parse-params"
+
+    (test "basic optional param"
+      (define result
+        (parse-params `((name ,as-string))
+                      '(("name" . "Alice"))))
+      (is (equal? "Alice" (assq-ref result 'name))))
+
+    (test "missing optional param omitted"
+      (define result
+        (parse-params `((name ,as-string))
+                      '()))
+      (is (not (assq-ref result 'name))))
+
+    (test "empty string treated as absent for optional"
+      (define result
+        (parse-params `((name ,as-string))
+                      '(("name" . ""))))
+      (is (not (assq-ref result 'name))))
+
+    (test "required param present"
+      (define result
+        (parse-params `((name ,as-string #:required))
+                      '(("name" . "Bob"))))
+      (is (equal? "Bob" (assq-ref result 'name))))
+
+    (test "required param missing"
+      (define result
+        (parse-params `((name ,as-string #:required))
+                      '()))
+      (is (invalid-param? (assq-ref result 'name))))
+
+    (test "required param empty"
+      (define result
+        (parse-params `((name ,as-string #:required))
+                      '(("name" . ""))))
+      (is (invalid-param? (assq-ref result 'name))))
+
+    (test "default used when absent"
+      (define result
+        (parse-params `((limit ,as-integer #:default 50))
+                      '()))
+      (is (equal? 50 (assq-ref result 'limit))))
+
+    (test "default not used when present"
+      (define result
+        (parse-params `((limit ,as-integer #:default 50))
+                      '(("limit" . "10"))))
+      (is (equal? 10 (assq-ref result 'limit))))
+
+    (test "default used when empty string"
+      (define result
+        (parse-params `((limit ,as-integer #:default 50))
+                      '(("limit" . ""))))
+      (is (equal? 50 (assq-ref result 'limit))))
+
+    (test "multi-value collects all"
+      (define result
+        (parse-params `((color ,as-string #:multi-value))
+                      '(("color" . "red") ("color" . "blue"))))
+      (is (equal? '("red" "blue") (assq-ref result 'color))))
+
+    (test "multi-value empty omitted"
+      (define result
+        (parse-params `((color ,as-string #:multi-value))
+                      '()))
+      (is (not (assq-ref result 'color))))
+
+    (test "multi-value skips empty strings"
+      (define result
+        (parse-params `((color ,as-string #:multi-value))
+                      '(("color" . "red") ("color" . "") ("color" . "blue"))))
+      (is (equal? '("red" "blue") (assq-ref result 'color))))
+
+    (test "multi-value with default"
+      (define result
+        (parse-params `((color ,as-string #:multi-value #:default ("red")))
+                      '()))
+      (is (equal? '("red") (assq-ref result 'color))))
+
+    (test "no-default-when suppresses default"
+      (define result
+        (parse-params `((limit ,as-integer
+                               #:no-default-when (all_results) #:default 50)
+                        (all_results ,as-checkbox))
+                      '(("all_results" . "on"))))
+      (is (not (assq-ref result 'limit)))
+      (is (eq? #t (assq-ref result 'all_results))))
+
+    (test "no-default-when uses default when condition absent"
+      (define result
+        (parse-params `((limit ,as-integer
+                               #:no-default-when (all_results) #:default 50))
+                      '()))
+      (is (equal? 50 (assq-ref result 'limit))))
+
+    (test "processor transforms value"
+      (define result
+        (parse-params `((count ,as-integer))
+                      '(("count" . "42"))))
+      (is (equal? 42 (assq-ref result 'count))))
+
+    (test "processor error appears inline"
+      (define result
+        (parse-params `((count ,as-integer))
+                      '(("count" . "abc"))))
+      (is (invalid-param? (assq-ref result 'count))))
+
+    (test "multiple params parsed together"
+      (define result
+        (parse-params `((name ,as-string #:required)
+                        (age ,as-integer #:default 0)
+                        (active ,as-checkbox))
+                      '(("name" . "Alice") ("active" . "on"))))
+      (is (equal? "Alice" (assq-ref result 'name)))
+      (is (equal? 0 (assq-ref result 'age)))
+      (is (eq? #t (assq-ref result 'active)))))
+
+  (suite "any-invalid-params?"
+
+    (test "no errors"
+      (is (not (any-invalid-params?
+                '((name . "Alice") (age . 30))))))
+
+    (test "with error"
+      (is (any-invalid-params?
+           `((name . ,(make-invalid-param #f "required"))))))
+
+    (test "error in multi-value list"
+      (is (any-invalid-params?
+           `((colors . ("red" ,(make-invalid-param "x" "bad"))))))))
+
+  (suite "invalid-param-ref"
+
+    (test "returns record when invalid"
+      (define params `((name . ,(make-invalid-param "" "required"))))
+      (is (invalid-param? (invalid-param-ref params 'name))))
+
+    (test "returns #f when valid"
+      (is (not (invalid-param-ref '((name . "Alice")) 'name))))
+
+    (test "returns #f when absent"
+      (is (not (invalid-param-ref '() 'name)))))
+
+  (suite "field-errors"
+
+    (test "returns error messages"
+      (define params `((name . ,(make-invalid-param "" "required"))))
+      (is (equal? '("required") (field-errors params 'name))))
+
+    (test "returns empty for valid field"
+      (is (equal? '() (field-errors '((name . "Alice")) 'name))))
+
+    (test "returns empty for absent field"
+      (is (equal? '() (field-errors '() 'name)))))
+
+  (suite "guard-against-mutually-exclusive-params"
+
+    (test "no conflict"
+      (define result
+        (guard-against-mutually-exclusive-params
+         '((limit . 50))
+         '((limit all_results))))
+      (is (equal? 50 (assq-ref result 'limit))))
+
+    (test "conflict marks both invalid"
+      (define result
+        (guard-against-mutually-exclusive-params
+         '((limit . 50) (all_results . #t))
+         '((limit all_results))))
+      (is (invalid-param? (assq-ref result 'limit)))
+      (is (invalid-param? (assq-ref result 'all_results))))
+
+    (test "preserves existing errors"
+      (define result
+        (guard-against-mutually-exclusive-params
+         `((name . ,(make-invalid-param #f "bad")))
+         '((name other))))
+      (is (invalid-param? (assq-ref result 'name)))))
+
+  (suite "params->query-string"
+
+    (test "simple params"
+      (is (equal? "name=Alice&age=30"
+                  (params->query-string '((name . "Alice") (age . 30))))))
+
+    (test "boolean params"
+      (is (equal? "active=on"
+                  (params->query-string '((active . #t))))))
+
+    (test "multi-value params"
+      (is (equal? "color=red&color=blue"
+                  (params->query-string '((color . ("red" "blue")))))))
+
+    (test "skips invalid params"
+      (is (equal? "name=Alice"
+                  (params->query-string
+                   `((name . "Alice")
+                     (bad . ,(make-invalid-param "x" "err")))))))
+
+    (test "empty result"
+      (is (equal? "" (params->query-string '())))))
+
+  (suite "parse-form-params"
+
+    (test "csrf pass"
+      (parameterize ((current-csrf-token "tok123"))
+        (define result
+          (parse-form-params
+           `((name ,as-string #:required))
+           '(("csrf-token" . "tok123") ("name" . "Alice"))))
+        (is (not (any-invalid-params? result)))
+        (is (equal? "Alice" (assq-ref result 'name)))))
+
+    (test "csrf fail"
+      (parameterize ((current-csrf-token "tok123"))
+        (define result
+          (parse-form-params
+           `((name ,as-string))
+           '(("csrf-token" . "wrong"))))
+        (is (any-invalid-params? result))))
+
+    (test "csrf missing"
+      (parameterize ((current-csrf-token "tok123"))
+        (define result
+          (parse-form-params `() '()))
+        (is (any-invalid-params? result))))))
+
+(run-tests params-tests)

tests/test-response-helpers.scm

@@ -0,0 +1,152 @@
+;; 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-response-helpers.scm — Tests for (safsaf response-helpers)
+
+(use-modules (tests support)
+             (safsaf response-helpers)
+             (safsaf router)
+             (srfi srfi-71)
+             (web response)
+             (web request)
+             (web uri))
+
+(define (body->string body)
+  "Capture a body (string or writer procedure) as a string."
+  (if (procedure? body)
+      (call-with-output-string body)
+      body))
+
+(define (make-request method path headers)
+  (build-request (build-uri 'http #:host "localhost" #:path path)
+                 #:method method
+                 #:headers headers))
+
+(define-suite response-helpers-tests
+
+  (suite "response constructors"
+
+    (test "html-response"
+      (let ((resp body (html-response '(p "hello"))))
+        (is (= 200 (response-code resp)))
+        (is (equal? '(text/html (charset . "utf-8"))
+                    (assq-ref (response-headers resp) 'content-type)))
+        (is (string-contains (body->string body) "hello"))))
+
+    (test "json-response"
+      (let ((resp body (json-response "{\"a\":1}")))
+        (is (= 200 (response-code resp)))
+        (is (equal? '(application/json)
+                    (assq-ref (response-headers resp) 'content-type)))
+        (is (equal? "{\"a\":1}" body))))
+
+    (test "text-response"
+      (let ((resp body (text-response "hi")))
+        (is (= 200 (response-code resp)))
+        (is (equal? "hi" body))))
+
+    (test "redirect-response"
+      (let ((resp _body (redirect-response "/foo")))
+        (is (= 303 (response-code resp)))
+        (is (response-headers resp))))
+
+    (test "custom code"
+      (let ((resp _body (text-response "x" #:code 201)))
+        (is (= 201 (response-code resp))))))
+
+  (suite "error responses"
+
+    (test "status codes"
+      (let ((r1 _b1 (not-found-response))
+            (r2 _b2 (forbidden-response))
+            (r3 _b3 (bad-request-response))
+            (r4 _b4 (internal-server-error-response)))
+        (is (= 404 (response-code r1)))
+        (is (= 403 (response-code r2)))
+        (is (= 400 (response-code r3)))
+        (is (= 500 (response-code r4))))))
+
+  (suite "streaming json"
+
+    (test "scm-alist->streaming-json"
+      (let ((out (call-with-output-string
+                   (lambda (port)
+                     (scm-alist->streaming-json
+                      '(("name" . "Alice") ("age" . 30))
+                      port)))))
+        (is (string-contains out "\"name\":\"Alice\""))
+        (is (string-contains out "\"age\":30"))))
+
+    (test "list->streaming-json-array"
+      (let ((out (call-with-output-string
+                   (lambda (port)
+                     (list->streaming-json-array
+                      identity '(1 2 3) port)))))
+        (is (equal? "[1,2,3]" out)))))
+
+  (suite "content negotiation"
+
+    (test "path extension takes priority over accept header"
+      (let ((req (make-request 'GET "/things.json"
+                               '((accept . ((text/html)))))))
+        (is (eq? 'application/json
+                 (negotiate-content-type req '(text/html application/json))))))
+
+    (test "falls back to accept header without extension"
+      (let ((req (make-request 'GET "/things"
+                               '((accept . ((application/json)))))))
+        (is (eq? 'application/json
+                 (negotiate-content-type req '(text/html application/json))))))
+
+    (test "ignores extension not in supported list"
+      (let ((req (make-request 'GET "/things.txt"
+                               '((accept . ((text/html)))))))
+        (is (eq? 'text/html
+                 (negotiate-content-type req '(text/html application/json))))))
+
+    (test "defaults to first supported when nothing matches"
+      (let ((req (make-request 'GET "/things"
+                               '((accept . ((image/png)))))))
+        (is (eq? 'text/html
+                 (negotiate-content-type req '(text/html application/json)))))))
+
+  (suite "static handler"
+
+    (test "serves file and rejects traversal"
+      (let* ((tmp (tmpnam))
+             (_   (mkdir tmp))
+             (f   (string-append tmp "/test.txt"))
+             (_   (call-with-output-file f
+                    (lambda (p) (display "content" p))))
+             (handler (make-static-handler tmp)))
+        ;; Serve existing file.
+        (parameterize ((current-route-params `((path . ("test.txt")))))
+          (let ((resp body (handler (make-request 'GET "/test.txt" '()) #f)))
+            (is (= 200 (response-code resp)))
+            (is (equal? "content" (body->string body)))))
+        ;; Traversal rejected.
+        (parameterize ((current-route-params `((path . (".." "etc" "passwd")))))
+          (let ((resp _body (handler (make-request 'GET "/../etc/passwd" '()) #f)))
+            (is (= 404 (response-code resp)))))
+        ;; Missing file.
+        (parameterize ((current-route-params `((path . ("nope.txt")))))
+          (let ((resp _body (handler (make-request 'GET "/nope.txt" '()) #f)))
+            (is (= 404 (response-code resp)))))
+        (delete-file f)
+        (rmdir tmp)))))
+
+(run-tests response-helpers-tests)

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)

tests/test-templating.scm

@@ -0,0 +1,102 @@
+;; 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-templating.scm — Tests for (safsaf templating)
+
+(use-modules (tests support)
+             (safsaf templating)
+             (htmlprag)
+             (srfi srfi-71)
+             (web response))
+
+(define (render shtml)
+  "Write SHTML via write-shtml-as-html/streaming and capture as a string."
+  (call-with-output-string
+    (lambda (port) (write-shtml-as-html/streaming shtml port))))
+
+(define-suite templating-tests
+
+  (suite "write-shtml-as-html/streaming"
+
+    (test "pure static shtml"
+      (let ((out (render '(p "hello"))))
+        (is (string-contains out "<p>hello</p>"))))
+
+    (test "single proc slot"
+      (let ((out (render
+                  `(div ,(lambda (port) (display "dynamic" port))))))
+        (is (string-contains out "dynamic"))))
+
+    (test "multiple slots in order"
+      (let ((out (render
+                  `(div ,(lambda (port) (display "AAA" port))
+                        ,(lambda (port) (display "BBB" port))))))
+        (let ((a (string-contains out "AAA"))
+              (b (string-contains out "BBB")))
+          (is a)
+          (is b)
+          (is (< a b)))))
+
+    (test "static content between slots preserved"
+      (let ((out (render
+                  `(div ,(lambda (port) (display "X" port))
+                        (hr)
+                        ,(lambda (port) (display "Y" port))))))
+        (is (string-contains out "<hr"))))
+
+    (test "nested element with proc child"
+      (let ((out (render
+                  `(html (body ,(lambda (port) (display "inner" port)))))))
+        (is (string-contains out "<body>inner</body>"))))
+
+    (test "attributes preserved"
+      (let ((out (render
+                  `(div (@ (class "box"))
+                        ,(lambda (port) (display "content" port))))))
+        (is (string-contains out "class=\"box\""))
+        (is (string-contains out "content"))))
+
+    (test "*TOP* with procs"
+      (let ((out (render
+                  `(*TOP*
+                    (*DECL* DOCTYPE html)
+                    (html (body ,(lambda (port) (display "hi" port))))))))
+        (is (string-contains out "<!DOCTYPE html>"))
+        (is (string-contains out "hi"))))
+
+    (test "proc can write shtml via htmlprag"
+      (let ((out (render
+                  `(div ,(lambda (port)
+                           (write-shtml-as-html '(p "from-proc") port))))))
+        (is (string-contains out "<p>from-proc</p>")))))
+
+  (suite "streaming-html-response"
+
+    (test "returns response and writer"
+      (let ((resp body (streaming-html-response '(p "hi"))))
+        (is (= 200 (response-code resp)))
+        (is (procedure? body))
+        (is (equal? '(text/html (charset . "utf-8"))
+                    (assq-ref (response-headers resp) 'content-type)))))
+
+    (test "body writes shtml with procs"
+      (let ((resp body (streaming-html-response
+                        `(div ,(lambda (port) (display "streamed" port))))))
+        (let ((out (call-with-output-string body)))
+          (is (string-contains out "streamed")))))))
+
+(run-tests templating-tests)

tests/test-utils.scm

@@ -0,0 +1,85 @@
+;; 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-utils.scm — Tests for (safsaf utils)
+
+(use-modules (tests support)
+             (safsaf utils)
+             (web request)
+             (web uri))
+
+(define* (make-request method path #:key (headers '()))
+  (build-request (string->uri (string-append "http://localhost" path))
+                 #:method method
+                 #:headers headers))
+
+(define-suite utils-tests
+  (suite "parse-query-string"
+    (test "parses key=value pairs"
+      (let* ((req (make-request 'GET "/?foo=bar&baz=qux"))
+             (qs (parse-query-string req)))
+        (is (equal? '(("foo" . "bar") ("baz" . "qux")) qs))))
+
+    (test "returns empty list when no query string"
+      (let* ((req (make-request 'GET "/"))
+             (qs (parse-query-string req)))
+        (is (null? qs))))
+
+    (test "decodes URL-encoded values"
+      (let* ((req (make-request 'GET "/?name=hello%20world"))
+             (qs (parse-query-string req)))
+        (is (equal? "hello world" (assoc-ref qs "name")))))
+
+    (test "handles key without value"
+      (let* ((req (make-request 'GET "/?flag"))
+             (qs (parse-query-string req)))
+        (is (equal? '(("flag" . "")) qs))))
+
+    (test "handles multiple values for same key"
+      (let* ((req (make-request 'GET "/?x=1&x=2"))
+             (qs (parse-query-string req)))
+        (is (= 2 (length qs)))
+        (is (equal? "1" (assoc-ref qs "x"))))))
+
+  (suite "request-cookies"
+    (test "parses cookie header"
+      (let* ((req (make-request 'GET "/"
+                                #:headers '((cookie . (("a" . "1")
+                                                       ("b" . "2"))))))
+             (cookies (request-cookies req)))
+        (is (equal? '(("a" . "1") ("b" . "2")) cookies))))
+
+    (test "returns empty list when no cookie header"
+      (let* ((req (make-request 'GET "/"))
+             (cookies (request-cookies req)))
+        (is (null? cookies)))))
+
+  (suite "request-cookie-ref"
+    (test "returns cookie value by name"
+      (let ((req (make-request 'GET "/"
+                               #:headers '((cookie . (("sid" . "abc123")))))))
+        (is (equal? "abc123" (request-cookie-ref req "sid")))))
+
+    (test "returns #f when cookie not found"
+      (let ((req (make-request 'GET "/")))
+        (is (not (request-cookie-ref req "missing")))))
+
+    (test "returns default when cookie not found"
+      (let ((req (make-request 'GET "/")))
+        (is (equal? "fallback" (request-cookie-ref req "missing" "fallback")))))))
+
+(run-tests utils-tests)