From 6ea10db973d861cd8774938e40151c0f8b2d266f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Oct 2017 23:19:09 +0200 Subject: 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 +++++++++++++++++++++++++++++----------------------- 1 file changed, 74 insertions(+), 59 deletions(-) (limited to 'guix/tests') 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 +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; 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 -- cgit v1.2.3