safsaf/tests/test-exceptions.scm

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