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
parent
e37415917c
commit
6ea10db973
@ -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)))
|
||||
|
||||
;; 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 @@ 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user