me
/
guix
Archived
1
0
Fork 0
Code

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).
master
Ludovic Courtès 2016-11-16 16:34:17 +01:00
parent 1bcc87bb68
commit 17ab08bcf0
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 141 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Makefile.am
View File

@ -171,8 +171,8 @@ MODULES += \
endif BUILD_DAEMON_OFFLOAD endif BUILD_DAEMON_OFFLOAD
# Internal module with test suite support. # Internal modules with test suite support.
dist_noinst_DATA = guix/tests.scm dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
# Linux-Libre configurations. # Linux-Libre configurations.
KCONFIGS = \ KCONFIGS = \
@ -189,7 +189,7 @@ EXAMPLES = \
gnu/system/examples/desktop.tmpl \ gnu/system/examples/desktop.tmpl \
gnu/system/examples/lightweight-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 = \ nobase_dist_guilemodule_DATA = \
$(MODULES) $(KCONFIGS) $(EXAMPLES) \ $(MODULES) $(KCONFIGS) $(EXAMPLES) \
@ -407,7 +407,7 @@ CLEANFILES = \
# the whole thing. Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly # the whole thing. Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly
# stale files from ~/.cache/guile/ccache. # stale files from ~/.cache/guile/ccache.
%.go: make-go ; @: %.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..." ; \ $(AM_V_at)echo "Compiling Scheme modules..." ; \
unset GUILE_LOAD_COMPILED_PATH ; \ unset GUILE_LOAD_COMPILED_PATH ; \
XDG_CACHE_HOME=/nowhere \ XDG_CACHE_HOME=/nowhere \

120
guix/tests/http.scm 100644
View File

@ -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

114
tests/lint.scm
View File

@ -24,6 +24,7 @@
(define-module (test-lint) (define-module (test-lint)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix tests http)
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix git-download) #:use-module (guix git-download)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
@ -33,101 +34,20 @@
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages glib) #:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config) #: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 match)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))
;; Test the linter. ;; Test the linter.
(define %http-server-port ;; Avoid collisions with other tests.
;; TCP port to use for the stub HTTP server. (%http-server-port 9999)
9999)
(define %local-url
;; URL to use for 'home-page' tests.
(string-append "http://localhost:" (number->string %http-server-port)
"/foo/bar"))
(define %null-sha256 (define %null-sha256
;; SHA256 of the empty string. ;; SHA256 of the empty string.
(base32 (base32
"0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73")) "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 (define %long-string
(make-string 2000 #\a)) (make-string 2000 #\a))
@ -423,28 +343,28 @@ string) on HTTP requests."
(check-home-page pkg))) (check-home-page pkg)))
"domain not found"))) "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" (test-assert "home-page: Connection refused"
(->bool (->bool
(string-contains (string-contains
(with-warnings (with-warnings
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page %local-url)))) (home-page (%local-url)))))
(check-home-page pkg))) (check-home-page pkg)))
"Connection refused"))) "Connection refused")))
(test-skip (if %http-server-socket 0 1)) (test-skip (if (force %http-server-socket) 0 1))
(test-equal "home-page: 200" (test-equal "home-page: 200"
"" ""
(with-warnings (with-warnings
(with-http-server 200 %long-string (with-http-server 200 %long-string
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page %local-url)))) (home-page (%local-url)))))
(check-home-page pkg))))) (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" (test-assert "home-page: 200 but short length"
(->bool (->bool
(string-contains (string-contains
@ -452,11 +372,11 @@ string) on HTTP requests."
(with-http-server 200 "This is too small." (with-http-server 200 "This is too small."
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page %local-url)))) (home-page (%local-url)))))
(check-home-page pkg)))) (check-home-page pkg))))
"suspiciously small"))) "suspiciously small")))
(test-skip (if %http-server-socket 0 1)) (test-skip (if (force %http-server-socket) 0 1))
(test-assert "home-page: 404" (test-assert "home-page: 404"
(->bool (->bool
(string-contains (string-contains
@ -464,7 +384,7 @@ string) on HTTP requests."
(with-http-server 404 %long-string (with-http-server 404 %long-string
(let ((pkg (package (let ((pkg (package
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(home-page %local-url)))) (home-page (%local-url)))))
(check-home-page pkg)))) (check-home-page pkg))))
"not reachable: 404"))) "not reachable: 404")))
@ -545,7 +465,7 @@ string) on HTTP requests."
(check-source-file-name pkg))) (check-source-file-name pkg)))
"file name should contain the package name")))) "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" (test-equal "source: 200"
"" ""
(with-warnings (with-warnings
@ -554,11 +474,11 @@ string) on HTTP requests."
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri %local-url) (uri (%local-url))
(sha256 %null-sha256)))))) (sha256 %null-sha256))))))
(check-source pkg))))) (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" (test-assert "source: 200 but short length"
(->bool (->bool
(string-contains (string-contains
@ -568,12 +488,12 @@ string) on HTTP requests."
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri %local-url) (uri (%local-url))
(sha256 %null-sha256)))))) (sha256 %null-sha256))))))
(check-source pkg)))) (check-source pkg))))
"suspiciously small"))) "suspiciously small")))
(test-skip (if %http-server-socket 0 1)) (test-skip (if (force %http-server-socket) 0 1))
(test-assert "source: 404" (test-assert "source: 404"
(->bool (->bool
(string-contains (string-contains
@ -583,7 +503,7 @@ string) on HTTP requests."
(inherit (dummy-package "x")) (inherit (dummy-package "x"))
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri %local-url) (uri (%local-url))
(sha256 %null-sha256)))))) (sha256 %null-sha256))))))
(check-source pkg)))) (check-source pkg))))
"not reachable: 404"))) "not reachable: 404")))