mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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).
This commit is contained in:
Ludovic Courtès
parent
1bcc87bb68
commit
17ab08bcf0
3 changed files with 141 additions and 101 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
120
guix/tests/http.scm
Normal file
120
guix/tests/http.scm
Normal 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
114
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 @@ (define-module (test-lint)
|
|||
#: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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(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 @@ (define-syntax-rule (with-warnings body ...)
|
|||
(inherit (dummy-package "x"))
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri %local-url)
|
||||
(uri (%local-url))
|
||||
(sha256 %null-sha256))))))
|
||||
(check-source pkg))))
|
||||
"not reachable: 404")))
|
||||
|
|
|
|||
Loading…
Reference in a new issue