From: Maxime Devos <maximedevos@telenet.be>
To: 53389@debbugs.gnu.org
Cc: ludo@gnu.org, Maxime Devos <maximedevos@telenet.be>
Subject: [bug#53389] [PATCH 1/9] tests: Support arbitrary HTTP request handlers.
Date: Thu, 20 Jan 2022 13:08:41 +0000 [thread overview]
Message-ID: <20220120130849.292178-1-maximedevos@telenet.be> (raw)
In-Reply-To: <6b1c1d98514b2547907a81a04c1241d9b865d6fa.camel@telenet.be>
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@gnu.org>
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@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@gnu.org>
+;;; Copyright © 2022 Maxime Devos <maximedevos@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
next prev parent reply other threads:[~2022-01-20 19:44 UTC|newest]
Thread overview: 25+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-01-20 12:59 [bug#53389] [PATCH 0/9] Replace some mocking with with-http-server*, avoid hardcoding ports, Maxime Devos
2022-01-20 13:08 ` Maxime Devos [this message]
2022-01-20 13:08 ` [bug#53389] [PATCH 2/9] tests: Generalise %local-url Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 3/9] tests/minetest: Run a HTTP server instead of mocking Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 4/9] tests/import-github: " Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 5/9] tests/cpan: Do not hard code a HTTP port Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 6/9] tests/lint: Do not assume the next port is free Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 7/9] tests: Allow checking the URI of a HTTP request Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 8/9] tests/cpan: Verify URIs Maxime Devos
2022-01-20 13:08 ` [bug#53389] [PATCH 9/9] tests/challenge: Do not hard code HTTP ports Maxime Devos
2022-01-22 16:48 ` [bug#53389] [PATCH 0/9] Replace some mocking with with-http-server*, avoid hardcoding ports, Ludovic Courtès
2022-01-22 18:55 ` Maxime Devos
2022-01-25 7:54 ` Ludovic Courtès
2022-01-25 13:37 ` Maxime Devos
2022-02-07 9:53 ` Ludovic Courtès
2022-02-07 10:59 ` Maxime Devos
2022-03-06 16:23 ` Ludovic Courtès
2022-03-07 7:00 ` Maxime Devos
2022-01-22 19:21 ` Maxime Devos
2022-01-22 19:57 ` Maxime Devos
2022-01-22 20:42 ` Maxime Devos
2022-01-22 18:08 ` [bug#53389] [PATCH 1/9] tests: Support arbitrary HTTP request handlers Maxime Devos
2022-01-20 15:11 ` [bug#53389] [PATCH 0/9] Replace some mocking with with-http-server*, avoid hardcoding ports, Ludovic Courtès
2022-04-12 19:46 ` [bug#53389] [PATCH 0/9] Replace some mocking with with-http-server Maxime Devos
2022-04-21 15:20 ` [bug#53389] [PATCH v2 0/25] Replace some mocking with with-http-server*, avoid harcoding ports Maxime Devos
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20220120130849.292178-1-maximedevos@telenet.be \
--to=maximedevos@telenet.be \
--cc=53389@debbugs.gnu.org \
--cc=ludo@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).