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-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)