From 4655005e2441c7001a89293242719fe35b894e40 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 Jan 2015 11:08:23 +0100 Subject: tests: Properly synchronize threads in the 'home-page' lint tests. * tests/lint.scm (%http-server-lock, %http-server-ready): New variables. (http-open): New procedure. (stub-http-server): Use it. (call-with-http-server): Wrap body in 'with-mutex'. Call 'wait-condition-variable' after 'make-thread'. --- tests/lint.scm | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/tests/lint.scm b/tests/lint.scm index c6931329d6..27be5598de 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014 Eric Bavier -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,9 +75,20 @@ (define (http-write server client response body) (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. - (@@ (web server http) http-open) + http-open (@@ (web server http) http-read) http-write (@@ (web server http) http-close)) @@ -97,9 +108,11 @@ (define (handle request body) `(#:socket ,%http-server-socket))) (const #t))) - (let* ((server (make-thread server-body))) - ;; Normally SERVER exits automatically once it has received a request. - (thunk))) + (with-mutex %http-server-lock + (let ((server (make-thread server-body))) + (wait-condition-variable %http-server-ready %http-server-lock) + ;; Normally SERVER exits automatically once it has received a request. + (thunk)))) (define-syntax-rule (with-http-server code body ...) (call-with-http-server code (lambda () body ...))) -- cgit v1.2.3