aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-01-13 11:08:23 +0100
committerLudovic Courtès <ludo@gnu.org>2015-01-13 11:09:05 +0100
commit4655005e2441c7001a89293242719fe35b894e40 (patch)
tree3e3da64201bff536d5c5678f644c3d6882d4165a
parent35ed9306b980591f108e01c87a811b63df011fbf (diff)
downloadguix-4655005e2441c7001a89293242719fe35b894e40.tar
guix-4655005e2441c7001a89293242719fe35b894e40.tar.gz
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'.
-rw-r--r--tests/lint.scm23
1 files 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 <tipecaml@gmail.com>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -75,9 +75,20 @@
(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 @@ requests."
`(#: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 ...)))