safsaf/tests/test-response-helpers.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-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)