cbaines/safsaf
cbaines/safsaf
1
Fork 0
Code Issues Pull requests Projects Releases Activity Actions

Initial commit
All checks were successful
/ test (push) Successful in 9s
Details

Browse source 
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.
This commit is contained in:
Christopher Baines 2026-04-13 14:24:19 +03:00
commit 5b0e6397dc
53 changed files with 7427 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

152
tests/test-response-helpers.scm Normal file
View file

@ -0,0 +1,152 @@
;; 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)