ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: Properly synchronize threads in the 'home-page' lint tests.

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2015-01-13 11:08:23 +01:00
parent 35ed9306b9
commit 4655005e24
1 changed files with 18 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
tests/lint.scm
View file

@ -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 @@ (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 ...)))