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.
This commit is contained in:
Ludovic Courtès 2017-10-12 23:19:09 +02:00
parent e37415917c
commit 6ea10db973
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 87 additions and 72 deletions

View file

@ -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 @@ (define-module (guix tests http)
#: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 @@ (define %http-server-port
;; 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)))
;; 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-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)
(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))
(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-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 @@ (define (handle request body)
;; 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

View file

@ -222,7 +222,7 @@ (define prefix-len (string-length dir))
(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 @@ (define prefix-len (string-length dir))
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 @@ (define prefix-len (string-length dir))
(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 @@ (define prefix-len (string-length dir))
(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

View file

@ -388,7 +388,7 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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 @@ (define-syntax-rule (with-warnings body ...)
(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