[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: tests: Support multiple HTTP server instances.
|
From: |
Ludovic Courtès |
|
Subject: |
01/04: tests: Support multiple HTTP server instances. |
|
Date: |
Thu, 12 Oct 2017 17:48:07 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 6ea10db973d861cd8774938e40151c0f8b2d266f
Author: Ludovic Courtès <address@hidden>
Date: Thu Oct 12 23:19:09 2017 +0200
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.
---
guix/tests/http.scm | 133 ++++++++++++++++++++++++++++----------------------
tests/derivations.scm | 8 +--
tests/lint.scm | 14 +++---
3 files changed, 85 insertions(+), 70 deletions(-)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index fe1e120..a56d6f2 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 <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
;;;
;;; 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
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f3aad1b..36afd42 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -222,7 +222,7 @@
(build-derivations %store (list drv))
#f)))
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder"
(let ((text (random-text)))
@@ -238,7 +238,7 @@
get-string-all)
text))))))
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder, invalid hash"
(with-http-server 200 "hello, world!"
@@ -253,7 +253,7 @@
(build-derivations %store (list drv))
#f))))
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder, not found"
(with-http-server 404 "not found"
@@ -279,7 +279,7 @@
(build-derivations %store (list drv))
#f)))
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
(test-skip 1))
(test-assert "'download' built-in builder, check mode"
;; Make sure rebuilding the 'builtin:download' derivation in check mode
diff --git a/tests/lint.scm b/tests/lint.scm
index 7610a91..d7254bc 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -388,7 +388,7 @@
(check-home-page pkg)))
"domain not found")))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: Connection refused"
(->bool
(string-contains
@@ -399,7 +399,7 @@
(check-home-page pkg)))
"Connection refused")))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200"
""
(with-warnings
@@ -409,7 +409,7 @@
(home-page (%local-url)))))
(check-home-page pkg)))))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 200 but short length"
(->bool
(string-contains
@@ -421,7 +421,7 @@
(check-home-page pkg))))
"suspiciously small")))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 404"
(->bool
(string-contains
@@ -510,7 +510,7 @@
(check-source-file-name pkg)))
"file name should contain the package name"))))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
""
(with-warnings
@@ -523,7 +523,7 @@
(sha256 %null-sha256))))))
(check-source pkg)))))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 200 but short length"
(->bool
(string-contains
@@ -538,7 +538,7 @@
(check-source pkg))))
"suspiciously small")))
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 404"
(->bool
(string-contains