M Makefile.am => Makefile.am +4 -4
@@ 171,8 171,8 @@ MODULES += \
endif BUILD_DAEMON_OFFLOAD
-# Internal module with test suite support.
-dist_noinst_DATA = guix/tests.scm
+# Internal modules with test suite support.
+dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
# Linux-Libre configurations.
KCONFIGS = \
@@ 189,7 189,7 @@ EXAMPLES = \
gnu/system/examples/desktop.tmpl \
gnu/system/examples/lightweight-desktop.tmpl
-GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go guix/tests.go
+GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go $(dist_noinst_DATA:%.scm=%.go)
nobase_dist_guilemodule_DATA = \
$(MODULES) $(KCONFIGS) $(EXAMPLES) \
@@ 407,7 407,7 @@ CLEANFILES = \
# the whole thing. Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly
# stale files from ~/.cache/guile/ccache.
%.go: make-go ; @:
-make-go: $(MODULES) guix/config.scm guix/tests.scm
+make-go: $(MODULES) guix/config.scm $(dist_noinst_DATA)
$(AM_V_at)echo "Compiling Scheme modules..." ; \
unset GUILE_LOAD_COMPILED_PATH ; \
XDG_CACHE_HOME=/nowhere \
A guix/tests/http.scm => guix/tests/http.scm +120 -0
@@ 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
M tests/lint.scm => tests/lint.scm +17 -97
@@ 24,6 24,7 @@
(define-module (test-lint)
#:use-module (guix tests)
+ #:use-module (guix tests http)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system gnu)
@@ 33,101 34,20 @@
#:use-module (gnu packages)
#:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config)
- #:use-module (web server)
- #:use-module (web server http)
- #:use-module (web response)
#:use-module (ice-9 match)
- #:use-module (ice-9 threads)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-64))
;; Test the linter.
-(define %http-server-port
- ;; TCP port to use for the stub HTTP server.
- 9999)
-
-(define %local-url
- ;; URL to use for 'home-page' tests.
- (string-append "http://localhost:" (number->string %http-server-port)
- "/foo/bar"))
+;; Avoid collisions with other tests.
+(%http-server-port 9999)
(define %null-sha256
;; SHA256 of the empty string.
(base32
"0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
-(define %http-server-socket
- ;; Socket used by the Web server.
- (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 ,%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 ...)))
-
(define %long-string
(make-string 2000 #\a))
@@ 423,28 343,28 @@ string) on HTTP requests."
(check-home-page pkg)))
"domain not found")))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-assert "home-page: Connection refused"
(->bool
(string-contains
(with-warnings
(let ((pkg (package
(inherit (dummy-package "x"))
- (home-page %local-url))))
+ (home-page (%local-url)))))
(check-home-page pkg)))
"Connection refused")))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-equal "home-page: 200"
""
(with-warnings
(with-http-server 200 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
- (home-page %local-url))))
+ (home-page (%local-url)))))
(check-home-page pkg)))))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-assert "home-page: 200 but short length"
(->bool
(string-contains
@@ 452,11 372,11 @@ string) on HTTP requests."
(with-http-server 200 "This is too small."
(let ((pkg (package
(inherit (dummy-package "x"))
- (home-page %local-url))))
+ (home-page (%local-url)))))
(check-home-page pkg))))
"suspiciously small")))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-assert "home-page: 404"
(->bool
(string-contains
@@ 464,7 384,7 @@ string) on HTTP requests."
(with-http-server 404 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
- (home-page %local-url))))
+ (home-page (%local-url)))))
(check-home-page pkg))))
"not reachable: 404")))
@@ 545,7 465,7 @@ string) on HTTP requests."
(check-source-file-name pkg)))
"file name should contain the package name"))))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-equal "source: 200"
""
(with-warnings
@@ 554,11 474,11 @@ string) on HTTP requests."
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
- (uri %local-url)
+ (uri (%local-url))
(sha256 %null-sha256))))))
(check-source pkg)))))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-assert "source: 200 but short length"
(->bool
(string-contains
@@ 568,12 488,12 @@ string) on HTTP requests."
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
- (uri %local-url)
+ (uri (%local-url))
(sha256 %null-sha256))))))
(check-source pkg))))
"suspiciously small")))
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
(test-assert "source: 404"
(->bool
(string-contains
@@ 583,7 503,7 @@ string) on HTTP requests."
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
- (uri %local-url)
+ (uri (%local-url))
(sha256 %null-sha256))))))
(check-source pkg))))
"not reachable: 404")))