summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-11-16 16:34:17 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-16 18:00:41 +0100
commit17ab08bcf0ae27ec6a1f07766080ebfbea8837d9 (patch)
treeac1b89effc9cd567fbeeb6f04d515628c7001465 /guix
parent1bcc87bb685b7985512add221f10e4cb58b5f6f7 (diff)
downloadgnu-guix-17ab08bcf0ae27ec6a1f07766080ebfbea8837d9.tar
gnu-guix-17ab08bcf0ae27ec6a1f07766080ebfbea8837d9.tar.gz
tests: Move HTTP server to (guix tests http).
* tests/lint.scm (%http-server-port, %local-url) (%http-server-socket, http-write, %http-server-lock) (%http-server-ready, http-open, stub-http-server) (call-with-http-server, with-http-server): Move to (guix tests http). Adjust tests for %HTTP-SERVER-SOCKET as a promise and %LOCAL-URL as a parameter. * guix/tests/http.scm: New file. * Makefile.am (dist_noinst_DATA): Add it. (GOBJECTS): Add .go files for all of $(dist_noinst_DATA). (make-go): Depend on $(dist_noinst_DATA).
Diffstat (limited to 'guix')
-rw-r--r--guix/tests/http.scm120
1 files changed, 120 insertions, 0 deletions
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
new file mode 100644
index 0000000000..fe1e120c5d
--- /dev/null
+++ b/guix/tests/http.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests http)
+ #:use-module (ice-9 threads)
+ #:use-module (web server)
+ #:use-module (web server http)
+ #:use-module (web response)
+ #:use-module (srfi srfi-39)
+ #:export (with-http-server
+ call-with-http-server
+ %http-server-port
+ %http-server-socket
+ %local-url))
+
+;;; Commentary:
+;;;
+;;; Code to spawn a Web server for testing purposes.
+;;;
+;;; Code:
+
+(define %http-server-port
+ ;; TCP port to use for the stub HTTP server.
+ (make-parameter 9999))
+
+(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)
+ "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")
+ data))
+
+ (catch 'quit
+ (lambda ()
+ (run-server handle stub-http-server
+ `(#:socket ,(force %http-server-socket))))
+ (const #t)))
+
+ (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 data body ...)
+ (call-with-http-server code data (lambda () body ...)))
+
+;;; http.scm ends here