summaryrefslogtreecommitdiff
path: root/guix/tests
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-10-12 23:19:09 +0200
committerLudovic Courtès <ludo@gnu.org>2017-10-12 23:47:48 +0200
commit6ea10db973d861cd8774938e40151c0f8b2d266f (patch)
treed86b6ca502a946097c2a610158fbad4caa91260e /guix/tests
parente37415917c4758142c052cae46b3d84517b54ec2 (diff)
tests: Support multiple HTTP server instances.
* guix/tests/http.scm (%http-server-socket): Turn into... (open-http-server-socket): ... this procedure. (http-server-can-listen?): New procedure. (http-write, %http-server-lock, %http-server-ready) (http-open, stub-http-server): Move to 'call-with-http-server' body. (call-with-http-server): Add #:headers parameter. (with-http-server): Add an additional pattern with headers. * tests/derivations.scm: Use (http-server-can-listen?) instead of (force %http-server-socket). * tests/lint.scm: Likewise.
Diffstat (limited to 'guix/tests')
-rw-r--r--guix/tests/http.scm133
1 files changed, 74 insertions, 59 deletions
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index fe1e120c5d..a56d6f213d 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,7 +25,7 @@
#:export (with-http-server
call-with-http-server
%http-server-port
- %http-server-socket
+ http-server-can-listen?
%local-url))
;;; Commentary:
@@ -38,75 +38,85 @@
;; TCP port to use for the stub HTTP server.
(make-parameter 9999))
+(define (open-http-server-socket)
+ "Return a listening socket for the web server. It is useful to export it so
+that tests can check whether we succeeded opening the socket and tests skip if
+needed."
+ (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)))
+ sock))
+ (lambda args
+ (let ((err (system-error-errno args)))
+ (format (current-error-port)
+ "warning: cannot run Web server for tests: ~a~%"
+ (strerror err))
+ #f))))
+
+(define (http-server-can-listen?)
+ "Return #t if we managed to open a listening socket."
+ (and=> (open-http-server-socket)
+ (lambda (socket)
+ (close-port socket)
+ #t)))
+
(define (%local-url)
;; URL to use for 'home-page' tests.
(string-append "http://localhost:" (number->string (%http-server-port))
"/foo/bar"))
-(define %http-server-socket
- ;; Listening socket for the web server. It is useful to export it so that
- ;; tests can check whether we succeeded opening the socket and tests skip if
- ;; needed.
- (delay
- (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)))
- sock))
- (lambda args
- (let ((err (system-error-errno args)))
- (format (current-error-port)
- "warning: cannot run Web server for tests: ~a~%"
- (strerror err))
- #f)))))
-
-(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)
- (quit #t) ;exit the server thread
- (values)))
+(define* (call-with-http-server code data thunk
+ #:key (headers '()))
+ "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
+ (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)
+ (quit #t) ;exit the server thread
+ (values)))
-;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
+ ;; 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-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 (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
- (@@ (web server http) http-read)
- http-write
- (@@ (web server http) http-close))
+ (define-server-impl stub-http-server
+ ;; Stripped-down version of Guile's built-in HTTP server.
+ http-open
+ (@@ (web server http) http-read)
+ http-write
+ (@@ (web server http) http-close))
-(define (call-with-http-server code data thunk)
- "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
(define (server-body)
(define (handle request body)
(values (build-response #:code code
- #:reason-phrase "Such is life")
+ #:reason-phrase "Such is life"
+ #:headers headers)
data))
- (catch 'quit
- (lambda ()
- (run-server handle stub-http-server
- `(#:socket ,(force %http-server-socket))))
- (const #t)))
+ (let ((socket (open-http-server-socket)))
+ (catch 'quit
+ (lambda ()
+ (run-server handle stub-http-server
+ `(#:socket ,socket)))
+ (lambda _
+ (close-port socket)))))
(with-mutex %http-server-lock
(let ((server (make-thread server-body)))
@@ -114,7 +124,12 @@ string) on HTTP requests."
;; Normally SERVER exits automatically once it has received a request.
(thunk))))
-(define-syntax-rule (with-http-server code data body ...)
- (call-with-http-server code data (lambda () body ...)))
+(define-syntax with-http-server
+ (syntax-rules ()
+ ((_ (code headers) data body ...)
+ (call-with-http-server code data (lambda () body ...)
+ #:headers headers))
+ ((_ code data body ...)
+ (call-with-http-server code data (lambda () body ...)))))
;;; http.scm ends here