275 lines
11 KiB
Scheme
275 lines
11 KiB
Scheme
|
;; 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)
|