Package: guix-patches;
Reported by: Maxime Devos <maximedevos <at> telenet.be>
Date: Thu, 20 Jan 2022 13:01:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Maxime Devos <maximedevos <at> telenet.be> To: 53389 <at> debbugs.gnu.org Cc: ludo <at> gnu.org, Maxime Devos <maximedevos <at> telenet.be> Subject: [bug#53389] [PATCH 1/9] tests: Support arbitrary HTTP request handlers. Date: Thu, 20 Jan 2022 13:08:41 +0000
An incompatible change to with-http-server has been made: it now
also exits when the thunk exits. This change allows implementing
with-http-server*. It also keeps threads from lingering if the
thunk doesn't access all of RESPONSES+DATA.
Usually, this change is fine, but it does not interact nicely with
monads in tests/challenge, so a variant with-http-server/lingering
preserving the old behaviour has been defined.
* guix/tests/http.scm
(call-with-http-server): Extract most functionality to ...
(call-with-http-server*): ... this new procedure. Also stop the
server thread after 'thunk' returns instead of when the last response
has been sent unless requested not to.
(with-http-server/keep-lingering): New macro.
* tests/challenge.scm (call-mismatch-test): Use the 'keep-lingering'
variant of 'with-http-server'.
---
guix/tests/http.scm | 96 +++++++++++++++++++++++++++++++--------------
tests/challenge.scm | 24 ++++++------
2 files changed, 80 insertions(+), 40 deletions(-)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 8f50eaefca..c42b4b8176 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo <at> gnu.org>
-;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet.be>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos <at> telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,7 +26,10 @@
#:use-module (srfi srfi-39)
#:use-module (ice-9 match)
#:export (with-http-server
+ with-http-server/keep-lingering
+ with-http-server*
call-with-http-server
+ call-with-http-server*
%http-server-port
%local-url))
@@ -68,23 +71,15 @@ actually listened at (in case %http-server-port was 0)."
(string-append "http://localhost:" (number->string port)
"/foo/bar"))
-(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.
+(define* (call-with-http-server* handle thunk #:key (keep-lingering? #false)
+ (last-response? (const #false)))
+ "Call THUNK with an HTTP server running and responding to HTTP requests
+with HANDLE (see (guile)Web Server).
%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)))
- responses+data))
-
+The port listened at will be set for the dynamic extent of THUNK.
+The server will quit after THUNK returns, unless KEEP-LINGERING? is true.
+It will also quit if LAST-RESPONSE? returns true."
(define (http-write server client response body)
"Write RESPONSE."
(let* ((response (write-response response client))
@@ -94,8 +89,8 @@ The port listened at will be set for the dynamic extent of THUNK."
(else
(write-response-body response body)))
(close-port port)
- (when (null? responses)
- (quit #t)) ;exit the server thread
+ (when (last-response?)
+ (throw 'quit))
(values)))
;; Mutex and condition variable to synchronize with the HTTP server.
@@ -118,18 +113,15 @@ The port listened at will be set for the dynamic extent of THUNK."
(@@ (web server http) http-close))
(define (server-body)
- (define (handle request body)
- (match responses
- (((response data) rest ...)
- (set! responses rest)
- (values response data))))
-
(let-values (((socket port) (open-http-server-socket)))
(set! %http-real-server-port port)
(catch 'quit
(lambda ()
- (run-server handle stub-http-server
- `(#:socket ,socket)))
+ ;; HANDLE might want to include the port in its responses,
+ ;; so set %http-server-port here as well.
+ (parameterize ((%http-server-port port))
+ (run-server handle stub-http-server
+ `(#:socket ,socket))))
(lambda _
(close-port socket)))))
@@ -137,12 +129,58 @@ The port listened at will be set for the dynamic extent of THUNK."
(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)))))
+ (let-values ((results
+ (parameterize ((%http-server-port %http-real-server-port))
+ (thunk))))
+ (unless keep-lingering?
+ ;; exit the server thread
+ (system-async-mark (lambda () (throw 'quit)) server))
+ (apply values results)))))
+
+
+(define* (call-with-http-server responses+data thunk #:key (keep-lingering? #false))
+ "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.
+
+The argument RESPONSES+DATA is thunked. As such, RESPONSES+DATA can use
+%http-server-port. %http-server-port will be set to the port listened at.
+It will be set for the dynamic extent of THUNK and RESPONSES+DATA.
+
+The server will exit after the last response. When KEEP-LINGERING? is false,
+the server will also exit after THUNK returns."
+ (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)))
+ (responses+data)))
+ (define (handle request body)
+ (match (responses)
+ (((response data) rest ...)
+ (set! responses (const rest))
+ (values response data))))
+ (call-with-http-server* handle thunk #:keep-lingering? keep-lingering?
+ #:last-response?
+ (lambda () (null? (responses)))))
(define-syntax with-http-server
(syntax-rules ()
((_ responses+data body ...)
- (call-with-http-server responses+data (lambda () body ...)))))
+ (call-with-http-server (lambda () responses+data) (lambda () body ...)))))
+
+(define-syntax with-http-server/keep-lingering
+ (syntax-rules ()
+ ((_ responses+data body ...)
+ (call-with-http-server (lambda () responses+data) (lambda () body ...)
+ #:keep-lingering? #true))))
+
+(define-syntax with-http-server*
+ (syntax-rules ()
+ ((_ handle body ...)
+ (call-with-http-server* handle (lambda () body ...)))))
;;; http.scm ends here
diff --git a/tests/challenge.scm b/tests/challenge.scm
index fdd5fd238e..c9de33ed34 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -198,17 +199,18 @@ value."
(lambda (port)
(write-file out2 port)))))
(parameterize ((%http-server-port 9000))
- (with-http-server `((200 ,(make-narinfo item size1 hash1))
- (200 ,nar1))
- (parameterize ((%http-server-port 9001))
- (with-http-server `((200 ,(make-narinfo item size2 hash2))
- (200 ,nar2))
- (mlet* %store-monad ((urls -> (list (%local-url 9000)
- (%local-url 9001)))
- (reports (compare-contents (list item)
- urls)))
- (pk 'report reports)
- (return (proc (car reports))))))))))))
+ (with-http-server/keep-lingering
+ `((200 ,(make-narinfo item size1 hash1))
+ (200 ,nar1))
+ (parameterize ((%http-server-port 9001))
+ (with-http-server/keep-lingering
+ `((200 ,(make-narinfo item size2 hash2))
+ (200 ,nar2))
+ (mlet* %store-monad ((urls -> (list (%local-url 9000)
+ (%local-url 9001)))
+ (reports (compare-contents (list item)
+ urls)))
+ (return (proc (car reports))))))))))))
(test-assertm "differing-files"
(call-mismatch-test
base-commit: 1bd250783d7118c3101dd2a6e090f3d6904b24a0
--
2.30.2
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.