summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2023-05-17 12:00:36 +0200
committerLudovic Courtès <ludo@gnu.org>2023-05-31 23:25:24 +0200
commit09526da78f4f7c33e2c6b16c0b314d007f99d10f (patch)
treecb2658dbf295d01d3cfdf869a137e1f7717aebda
parent58da6b297c2696651d4c069678be0d2188eaec92 (diff)
tests: http: Allow responses to specify a path.
* guix/tests/http.scm (%local-url): Add #:path parameter and honor it. (call-with-http-server)[responses]: Add extra clause with 'path'. [bad-request]: New variable. [server-body]: Handle three-element clauses. Wrap 'run-server' call in 'parameterize'.
-rw-r--r--guix/tests/http.scm46
1 files changed, 40 insertions, 6 deletions
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 37e5744353..17485df9ef 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
@@ -21,7 +21,10 @@
#: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
@@ -60,12 +63,13 @@ actually listened at (in case %http-server-port was 0)."
(strerror err))
(values #f #f)))))
-(define* (%local-url #:optional (port (%http-server-port)))
+(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)
- "/foo/bar"))
+ path))
(define* (call-with-http-server responses+data thunk)
"Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
@@ -81,6 +85,18 @@ The port listened at will be set for the dynamic extent of THUNK."
(((? 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))
@@ -116,19 +132,37 @@ The port listened at will be set for the dynamic extent of THUNK."
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))))
+ (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 ()
- (run-server handle stub-http-server
- `(#:socket ,socket)))
+ ;; 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)))))