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