diff options
| -rw-r--r-- | Makefile.am | 8 | ||||
| -rw-r--r-- | guix/tests/http.scm | 120 | ||||
| -rw-r--r-- | tests/lint.scm | 114 |
3 files changed, 141 insertions, 101 deletions
diff --git a/Makefile.am b/Makefile.am index 908eaf6ec0..5d3639747f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 \ 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 diff --git a/tests/lint.scm b/tests/lint.scm index fa2d19b2a6..cf1b95ee69 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -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"))) |