Package: guix-patches;
Reported by: Romain GARBAGE <romain.garbage <at> inria.fr>
Date: Tue, 11 Mar 2025 10:34:01 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Romain GARBAGE <romain.garbage <at> inria.fr> To: 76938 <at> debbugs.gnu.org Cc: ludovic.courtes <at> inria.fr, Romain GARBAGE <romain.garbage <at> inria.fr> Subject: [bug#76938] [PATCH Cuirass 04/13] cuirass: tests: Add mock HTTP server for tests. 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 <ludo <at> gnu.org> +;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet.be> +;;; Copyright © 2025 Romain Garbage <romain.garbage <at> inria.fr> +;;; +;;; 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.