aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-12-29 20:39:58 +0100
committerLudovic Courtès <ludo@gnu.org>2014-12-29 21:17:36 +0100
commit907c98acbbf533715983c61a1e53cb29a52c4bef (patch)
treee228c54d454dd22085b0b2f3393462c326c46bcf
parent8f501ac849fe012e7aefb001cbd7b17801df36d7 (diff)
downloadguix-907c98acbbf533715983c61a1e53cb29a52c4bef.tar
guix-907c98acbbf533715983c61a1e53cb29a52c4bef.tar.gz
lint: Add tests for the 'home-page' checker.
Suggested by Cyril Roelandt <tipecaml@gmail.com>. * tests/lint.scm (%http-server-port, %http-server-socket, %local-url, stub-http-server): New variables. (http-write, call-with-http-server): New procedures. (with-http-server): New macro. ("home-page: wrong home-page", "home-page: invalid URI", "home-page: host not found", "home-page: Connection refused", "home-page: 200", "home-page: 404"): New tests. * guix/scripts/lint.scm (check-home-page): Export.
-rw-r--r--guix/scripts/lint.scm3
-rw-r--r--tests/lint.scm147
2 files changed, 148 insertions, 2 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9a0d997320..15ae213339 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -42,7 +42,8 @@
check-description-style
check-inputs-should-be-native
check-patches
- check-synopsis-style))
+ check-synopsis-style
+ check-home-page))
;;;
diff --git a/tests/lint.scm b/tests/lint.scm
index e77d443264..8ae129d9fe 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -26,10 +26,82 @@
#:use-module (guix ui)
#:use-module (gnu packages)
#:use-module (gnu packages pkg-config)
+ #:use-module (web server)
+ #:use-module (web server http)
+ #:use-module (web response)
+ #: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"))
+
+(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)))
+
+(define-server-impl stub-http-server
+ ;; Stripped-down version of Guile's built-in HTTP server.
+ (@@ (web server http) http-open)
+ (@@ (web server http) http-read)
+ http-write
+ (@@ (web server http) http-close))
+
+(define (call-with-http-server code thunk)
+ "Call THUNK with an HTTP server running and returning CODE on HTTP
+requests."
+ (define (server-body)
+ (define (handle request body)
+ (values (build-response #:code code
+ #:reason-phrase "Such is life")
+ "Hello, world."))
+
+ (catch 'quit
+ (lambda ()
+ (run-server handle stub-http-server
+ `(#:socket ,%http-server-socket)))
+ (const #t)))
+
+ (let* ((server (make-thread server-body)))
+ ;; Normally SERVER exits automatically once it has received a request.
+ (thunk)))
+
+(define-syntax-rule (with-http-server code body ...)
+ (call-with-http-server code (lambda () body ...)))
+
(test-begin "lint")
@@ -235,9 +307,82 @@
(sha256 "somesha")
(patches (list "/path/to/y.patch")))))))
(check-patches pkg))))
- "file names of patches should start with the package name")))
+ "file names of patches should start with the package name")))
+
+(test-assert "home-page: wrong home-page"
+ (->bool
+ (string-contains
+ (call-with-warnings
+ (lambda ()
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page #f))))
+ (check-home-page pkg))))
+ "invalid")))
+
+(test-assert "home-page: invalid URI"
+ (->bool
+ (string-contains
+ (call-with-warnings
+ (lambda ()
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page "foobar"))))
+ (check-home-page pkg))))
+ "invalid home page URL")))
+
+(test-assert "home-page: host not found"
+ (->bool
+ (string-contains
+ (call-with-warnings
+ (lambda ()
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page "http://does-not-exist"))))
+ (check-home-page pkg))))
+ "domain not found")))
+
+(test-skip (if %http-server-socket 0 1))
+(test-assert "home-page: Connection refused"
+ (->bool
+ (string-contains
+ (call-with-warnings
+ (lambda ()
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page %local-url))))
+ (check-home-page pkg))))
+ "Connection refused")))
+
+(test-skip (if %http-server-socket 0 1))
+(test-equal "home-page: 200"
+ ""
+ (call-with-warnings
+ (lambda ()
+ (with-http-server 200
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page %local-url))))
+ (check-home-page pkg))))))
+
+(test-skip (if %http-server-socket 0 1))
+(test-assert "home-page: 404"
+ (->bool
+ (string-contains
+ (call-with-warnings
+ (lambda ()
+ (with-http-server 404
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page %local-url))))
+ (check-home-page pkg)))))
+ "not reachable: 404")))
(test-end "lint")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;; Local Variables:
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
+;; End: