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:
commit
5b0e6397dc
53 changed files with 7427 additions and 0 deletions
273
tests/test-integration.scm
Normal file
273
tests/test-integration.scm
Normal file
|
|
@ -0,0 +1,273 @@
|
|||
;; 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-integration.scm — Full-stack integration tests
|
||||
;;;
|
||||
;;; Starts a real HTTP server inside run-fibers and makes requests
|
||||
;;; via a thread pool (Guile's (web client) uses blocking I/O that
|
||||
;;; does not cooperate with the fibers scheduler).
|
||||
|
||||
(use-modules (tests support)
|
||||
(fibers)
|
||||
(knots web-server)
|
||||
(knots thread-pool)
|
||||
(safsaf)
|
||||
(safsaf router)
|
||||
(safsaf response-helpers)
|
||||
(safsaf utils)
|
||||
(srfi srfi-71)
|
||||
(rnrs bytevectors)
|
||||
(web client)
|
||||
(web request)
|
||||
(web response)
|
||||
(web uri))
|
||||
|
||||
(define test-port 8399)
|
||||
(define test-base (string-append "http://127.0.0.1:"
|
||||
(number->string test-port)))
|
||||
|
||||
;;;
|
||||
;;; Test handlers
|
||||
;;;
|
||||
|
||||
(define (echo-form-handler request body-port)
|
||||
"Parse a URL-encoded form body and echo each field as key=value lines."
|
||||
(let ((fields (parse-form-body request body-port)))
|
||||
(text-response
|
||||
(string-join (map (lambda (pair)
|
||||
(string-append (car pair) "=" (cdr pair)))
|
||||
fields)
|
||||
"\n"))))
|
||||
|
||||
(define (echo-multipart-handler request body-port)
|
||||
"Parse a multipart body, extract text fields, echo as key=value lines."
|
||||
(let* ((parts (parse-multipart-body request body-port))
|
||||
(fields (multipart-text-fields parts)))
|
||||
(text-response
|
||||
(string-join (map (lambda (pair)
|
||||
(string-append (car pair) "=" (cdr pair)))
|
||||
fields)
|
||||
"\n"))))
|
||||
|
||||
(define (greet-handler request body-port)
|
||||
(text-response "hello"))
|
||||
|
||||
(define (catch-all-handler request body-port)
|
||||
(not-found-response))
|
||||
|
||||
;;;
|
||||
;;; Route table
|
||||
;;;
|
||||
|
||||
(define test-routes
|
||||
(list
|
||||
(route 'GET '("greet") greet-handler)
|
||||
(route 'POST '("form") echo-form-handler)
|
||||
(route 'POST '("multipart") echo-multipart-handler)
|
||||
(route '* '(. rest) catch-all-handler)))
|
||||
|
||||
;;;
|
||||
;;; Multipart body construction
|
||||
;;;
|
||||
|
||||
(define (make-multipart-body boundary fields)
|
||||
"Build a multipart/form-data body bytevector from FIELDS,
|
||||
an alist of (name . value) string pairs."
|
||||
(let ((parts
|
||||
(string-join
|
||||
(map (lambda (pair)
|
||||
(string-append
|
||||
"--" boundary "\r\n"
|
||||
"Content-Disposition: form-data; name=\""
|
||||
(car pair) "\"\r\n"
|
||||
"\r\n"
|
||||
(cdr pair)))
|
||||
fields)
|
||||
"\r\n")))
|
||||
(string->utf8
|
||||
(string-append parts "\r\n"
|
||||
"--" boundary "--\r\n"))))
|
||||
|
||||
;;;
|
||||
;;; Test runner
|
||||
;;;
|
||||
|
||||
(define %pass 0)
|
||||
(define %fail 0)
|
||||
|
||||
(define (check desc ok?)
|
||||
(if ok?
|
||||
(begin
|
||||
(set! %pass (1+ %pass))
|
||||
(format #t " ok ~a~%" desc))
|
||||
(begin
|
||||
(set! %fail (1+ %fail))
|
||||
(format #t " FAIL ~a~%" desc)))
|
||||
(force-output))
|
||||
|
||||
;;; HTTP client helper — runs requests on a thread pool because
|
||||
;;; Guile's (web client) uses blocking I/O incompatible with fibers.
|
||||
(define http-pool (make-fixed-size-thread-pool 1))
|
||||
|
||||
(define (test-post path headers body)
|
||||
"POST to the test server. Returns (values response body-string)."
|
||||
(call-with-thread
|
||||
http-pool
|
||||
(lambda ()
|
||||
(http-post (string-append test-base path)
|
||||
#:headers headers
|
||||
#:body body))))
|
||||
|
||||
(define (test-get path)
|
||||
"GET from the test server. Returns (values response body-string)."
|
||||
(call-with-thread
|
||||
http-pool
|
||||
(lambda ()
|
||||
(http-get (string-append test-base path)))))
|
||||
|
||||
(define (test-head path)
|
||||
"HEAD to the test server. Returns (values response body-string)."
|
||||
(call-with-thread
|
||||
http-pool
|
||||
(lambda ()
|
||||
(http-head (string-append test-base path)))))
|
||||
|
||||
(define (test-delete path)
|
||||
"DELETE to the test server. Returns (values response body-string)."
|
||||
(call-with-thread
|
||||
http-pool
|
||||
(lambda ()
|
||||
(http-delete (string-append test-base path)))))
|
||||
|
||||
;;;
|
||||
;;; Run everything inside a single run-fibers.
|
||||
;;;
|
||||
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(run-safsaf test-routes
|
||||
#:host "127.0.0.1"
|
||||
#:port test-port)
|
||||
|
||||
(sleep 1)
|
||||
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(format (current-error-port) "~%Test error: ~a~%" exn)
|
||||
(force-output (current-error-port))
|
||||
(primitive-_exit 1))
|
||||
(lambda ()
|
||||
|
||||
(format #t "parse-form-body via HTTP~%")
|
||||
|
||||
;; Test 1: basic url-encoded fields
|
||||
(let ((resp body
|
||||
(test-post "/form"
|
||||
'((content-type
|
||||
. (application/x-www-form-urlencoded)))
|
||||
"name=Alice&age=30")))
|
||||
(check "basic url-encoded fields"
|
||||
(and (= 200 (response-code resp))
|
||||
(string-contains body "name=Alice")
|
||||
(string-contains body "age=30"))))
|
||||
|
||||
;; Test 2: plus signs decoded as spaces
|
||||
(let ((resp body
|
||||
(test-post "/form"
|
||||
'((content-type
|
||||
. (application/x-www-form-urlencoded)))
|
||||
"greeting=hello+world")))
|
||||
(check "plus signs decoded as spaces"
|
||||
(and (= 200 (response-code resp))
|
||||
(string-contains body "greeting=hello world"))))
|
||||
|
||||
;; Test 3: percent-encoded values
|
||||
(let ((resp body
|
||||
(test-post "/form"
|
||||
'((content-type
|
||||
. (application/x-www-form-urlencoded)))
|
||||
"msg=caf%C3%A9")))
|
||||
(check "percent-encoded values"
|
||||
(and (= 200 (response-code resp))
|
||||
(string-contains body "msg=café"))))
|
||||
|
||||
(format #t "~%parse-multipart-body via HTTP~%")
|
||||
|
||||
;; Test 4: basic multipart text fields
|
||||
(let* ((boundary "----TestBoundary12345")
|
||||
(body-bv (make-multipart-body boundary
|
||||
'(("title" . "Hello")
|
||||
("body" . "World")))))
|
||||
(let ((resp body
|
||||
(test-post "/multipart"
|
||||
`((content-type
|
||||
. (multipart/form-data
|
||||
(boundary . ,boundary))))
|
||||
body-bv)))
|
||||
(check "basic multipart text fields"
|
||||
(and (= 200 (response-code resp))
|
||||
(string-contains body "title=Hello")
|
||||
(string-contains body "body=World")))))
|
||||
|
||||
(format #t "~%405 Method Not Allowed~%")
|
||||
|
||||
;; Test 5: POST to a GET-only route returns 405
|
||||
(let ((resp body (test-post "/greet" '() "")))
|
||||
(check "POST to GET-only route returns 405"
|
||||
(= 405 (response-code resp)))
|
||||
(check "405 response includes Allow header with GET and HEAD"
|
||||
(let ((allowed (assq-ref (response-headers resp)
|
||||
'allow)))
|
||||
(and (memq 'GET allowed)
|
||||
(memq 'HEAD allowed)))))
|
||||
|
||||
;; Test 6: DELETE to a GET-only route returns 405
|
||||
(let ((resp _body (test-delete "/greet")))
|
||||
(check "DELETE to GET-only route returns 405"
|
||||
(= 405 (response-code resp))))
|
||||
|
||||
(format #t "~%Automatic HEAD handling~%")
|
||||
|
||||
;; Test 7: HEAD to a GET route returns 200 with empty body
|
||||
(let ((resp body (test-head "/greet")))
|
||||
(check "HEAD to GET route returns 200"
|
||||
(= 200 (response-code resp)))
|
||||
(check "HEAD response has empty body"
|
||||
(or (not body)
|
||||
(and (string? body) (string-null? body)))))
|
||||
|
||||
;; Test 8: HEAD to a non-existent path falls through to catch-all
|
||||
(let ((resp _body (test-head "/no-such-path")))
|
||||
(check "HEAD to unknown path returns 404"
|
||||
(= 404 (response-code resp))))
|
||||
|
||||
;; Test 9: GET to the greet route works normally
|
||||
(let ((resp body (test-get "/greet")))
|
||||
(check "GET to greet route returns 200"
|
||||
(= 200 (response-code resp)))
|
||||
(check "GET to greet route returns body"
|
||||
(string-contains body "hello")))
|
||||
|
||||
;; Summary and exit.
|
||||
(newline)
|
||||
(let ((total (+ %pass %fail)))
|
||||
(format #t "~a passed, ~a failed (of ~a)~%"
|
||||
%pass %fail total)
|
||||
(force-output)
|
||||
(primitive-_exit (if (zero? %fail) 0 1))))
|
||||
#:unwind? #t))
|
||||
#:drain? #f)
|
||||
Loading…
Add table
Add a link
Reference in a new issue