Subject: [bug#76938] [PATCH Cuirass 04/13] cuirass: tests: Add mock HTTP server for tests.

From: Romain GARBAGE <[email-masked]>
Date: Tue, 11 Mar 2025 11:34:29 +0100

* src/cuirass/tests/http.scm: New module.
(%http-server-port, open-http-server-socket, %local-url, %received-requests+request-bodies, call-with-http-server, with-http-server): New variables.
* Makefile.am (nodist_noinst_DATA): Declare new module to the build system.
---
 Makefile.am                |   3 +
 src/cuirass/tests/http.scm | 192 +++++++++++++++++++++++++++++++++++++
 2 files changed, 195 insertions(+)
 create mode 100644 src/cuirass/tests/http.scm

diff --git a/Makefile.am b/Makefile.am
index d5bb509..e1d2cb6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -100,6 +100,9 @@ nodist_scriptsobject_DATA =			\
 nodist_webobject_DATA =				\
   $(dist_webmodule_DATA:.scm=.go)
 
+nodist_noinst_DATA =			\
+  src/cuirass/tests/http.scm
+
 dist_pkgdata_DATA = src/schema.sql
 
 dist_sql_DATA = 				\
diff --git a/src/cuirass/tests/http.scm b/src/cuirass/tests/http.scm
new file mode 100644
index 0000000..62b0910
--- /dev/null
+++ b/src/cuirass/tests/http.scm
@@ -0,0 +1,192 @@
+;;; http.scm -- HTTP mock server for tests.
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2021 Maxime Devos <[email-masked]>
+;;; Copyright © 2025 Romain Garbage <[email-masked]>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass tests http)
+  #:use-module (ice-9 threads)
+  #:use-module (web server)
+  #:use-module (web server http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:export (with-http-server
+            call-with-http-server
+            %http-server-port
+            %local-url
+            %last-request
+            %last-request-body))
+
+
+;;;
+;;; Mock HTTP server.
+;;; Adapted from (guix tests http) module.
+;;;
+
+(define %http-server-port
+  ;; TCP port to use for the stub HTTP server.
+  ;; If 0, the OS will automatically choose
+  ;; a port.
+  (make-parameter 0))
+
+(define (open-http-server-socket)
+  "Return a listening socket for the web server and the port
+actually listened at (in case %http-server-port was 0)."
+  (catch 'system-error
+    (lambda ()
+      (let ((sock (socket PF_INET SOCK_STREAM 0)))
+        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+        (bind sock
+              (make-socket-address AF_INET INADDR_LOOPBACK
+                                   (%http-server-port)))
+        (values sock
+                (sockaddr:port (getsockname sock)))))
+    (lambda args
+      (let ((err (system-error-errno args)))
+        (format (current-error-port)
+                "warning: cannot run Web server for tests: ~a~%"
+                (strerror err))
+        (values #f #f)))))
+
+(define* (%local-url #:optional (port (%http-server-port))
+                     #:key (path "/foo/bar"))
+  (when (= port 0)
+    (error "no web server is running!"))
+  ;; URL to use for 'home-page' tests.
+  (string-append "http://localhost:" (number->string port)
+                 path))
+
+(define %received-requests+request-bodies '())
+
+(define* (call-with-http-server responses+data thunk)
+  "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests.  Each element of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string.
+
+%http-server-port will be set to the port listened at
+The port listened at will be set for the dynamic extent of THUNK."
+  (define responses
+    (map (match-lambda
+           (((? response? response) data)
+            (list response data))
+           (((? integer? code) data)
+            (list (build-response #:code code
+                                  #:reason-phrase "Such is life")
+                  data))
+           (((? string? path) (? integer? code) data)
+            (list path
+                  (build-response #:code code
+                                  #:headers
+                                  (if (string? data)
+                                      '()
+                                      '((content-type ;binary data
+                                         . (application/octet-stream
+                                            (charset
+                                             . "ISO-8859-1")))))
+                                  #:reason-phrase "Such is life")
+                  data)))
+         responses+data))
+
+  (define (http-write server client response body)
+    "Write RESPONSE."
+    (let* ((response (write-response response client))
+           (port     (response-port response)))
+      (cond
+       ((not body))                     ;pass
+       (else
+        (write-response-body response body)))
+      (close-port port)
+      (when (null? responses)
+        (quit #t))                      ;exit the server thread
+      (values)))
+
+  (define (http-read server)
+    (let-values (((client request body) ((@@ (web server http) http-read) server)))
+      (set! %received-requests+request-bodies
+            (acons request
+                   body
+                   %received-requests+request-bodies))
+      (values client request body)))
+
+  ;; Mutex and condition variable to synchronize with the HTTP server.
+  (define %http-server-lock (make-mutex))
+  (define %http-server-ready (make-condition-variable))
+  (define %http-real-server-port #f)
+
+  (define (http-open . args)
+    "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+    (with-mutex %http-server-lock
+      (let ((result (apply (@@ (web server http) http-open) args)))
+        (signal-condition-variable %http-server-ready)
+        result)))
+
+  (define-server-impl stub-http-server
+    ;; Stripped-down version of Guile's built-in HTTP server.
+    http-open
+    http-read
+    http-write
+    (@@ (web server http) http-close))
+
+  (define bad-request
+    (build-response #:code 400 #:reason-phrase "Unexpected request"))
+
+  (define (server-body)
+    (define (handle request body)
+      (match responses
+        (((response data) rest ...)
+         (set! responses rest)
+         (values response data))
+        ((((? string?) response data) ...)
+         (let ((path (uri-path (request-uri request))))
+           (match (assoc path responses)
+             (#f (values bad-request ""))
+             ((_ response data)
+              (if (eq? 'GET (request-method request))
+                  ;; Note: Use 'assoc-remove!' to remove only the first entry
+                  ;; with PATH as its key.  That way, RESPONSES can contain
+                  ;; the same path several times.
+                  (let ((rest (assoc-remove! responses path)))
+                    (set! responses rest)
+                    (values response data))
+                  (values bad-request ""))))))))
+
+    (let-values (((socket port) (open-http-server-socket)))
+      (set! %http-real-server-port port)
+      (catch 'quit
+        (lambda ()
+          ;; Let HANDLE refer to '%http-server-port' if needed.
+          (parameterize ((%http-server-port %http-real-server-port))
+            (run-server handle stub-http-server
+                        `(#:socket ,socket))))
+        (lambda _
+          (close-port socket)))))
+
+  (with-mutex %http-server-lock
+    (let ((server (make-thread server-body)))
+      (wait-condition-variable %http-server-ready %http-server-lock)
+      ;; Normally SERVER exits automatically once it has received a request.
+      (parameterize ((%http-server-port %http-real-server-port))
+        (thunk)))))
+
+(define-syntax with-http-server
+  (syntax-rules ()
+    ((_ responses+data body ...)
+     (call-with-http-server responses+data (lambda () body ...)))))
-- 
2.48.1