safsaf/tests/test-handler-wrappers.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-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)