From 17ab08bcf0ae27ec6a1f07766080ebfbea8837d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Nov 2016 16:34:17 +0100 Subject: 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). --- tests/lint.scm | 114 +++++++++------------------------------------------------ 1 file changed, 17 insertions(+), 97 deletions(-) (limited to 'tests/lint.scm') 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"))) -- cgit v1.2.3 From fac46e3f5e55f9de6fa2ab8082bc418139590fc0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 19 Nov 2016 18:06:46 +0100 Subject: lint: Add 'mirror-url' checker. * guix/scripts/lint.scm (origin-uris): New procedure. (check-source): Use it. (check-mirror-url): New procedure. (%checkers): Add 'mirror-url' checker. * tests/lint.scm ("mirror-url") ("mirror-url: one suggestion"): New tests. * doc/guix.texi (Invoking guix lint): Document it. --- doc/guix.texi | 4 +++- guix/scripts/lint.scm | 43 +++++++++++++++++++++++++++++++++++++++---- tests/lint.scm | 19 +++++++++++++++++++ 3 files changed, 61 insertions(+), 5 deletions(-) (limited to 'tests/lint.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 0e70830d02..7352ea973f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5379,9 +5379,11 @@ Identify inputs that should most likely be native inputs. @item source @itemx home-page +@itemx mirror-url @itemx source-file-name Probe @code{home-page} and @code{source} URLs and report those that are -invalid. Check that the source file name is meaningful, e.g. is not +invalid. Suggest a @code{mirror://} URL when applicable. Check that +the source file name is meaningful, e.g. is not just a version number or ``git-checkout'', without a declared @code{file-name} (@pxref{origin Reference}). diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 6e6f550941..9641d3926a 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -65,6 +65,7 @@ check-home-page check-source check-source-file-name + check-mirror-url check-license check-vulnerabilities check-formatting @@ -567,6 +568,14 @@ descriptions maintained upstream." (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) +(define (origin-uris origin) + "Return the list of URIs (strings) for ORIGIN." + (match (origin-uri origin) + ((? string? uri) + (list uri)) + ((uris ...) + uris))) + (define (check-source package) "Emit a warning if PACKAGE has an invalid 'source' field, or if that 'source' is not reachable." @@ -583,10 +592,7 @@ descriptions maintained upstream." (let ((origin (package-source package))) (when (and origin (eqv? (origin-method origin) url-fetch)) - (let* ((strings (origin-uri origin)) - (uris (if (list? strings) - (map string->uri strings) - (list (string->uri strings))))) + (let ((uris (map string->uri (origin-uris origin)))) ;; Just make sure that at least one of the URIs is valid. (call-with-values @@ -626,6 +632,31 @@ descriptions maintained upstream." (_ "the source file name should contain the package name") 'source)))) +(define (check-mirror-url package) + "Check whether PACKAGE uses source URLs that should be 'mirror://'." + (define (check-mirror-uri uri) ;XXX: could be optimized + (let loop ((mirrors %mirrors)) + (match mirrors + (() + #t) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (emit-warning package + (format #f (_ "URL should be \ +'mirror://~a/~a'") + mirror-id + (string-drop uri (string-length prefix))) + 'source))))))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-mirror-uri uris))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (catch #t @@ -863,6 +894,10 @@ or a list thereof") (name 'source) (description "Validate source URLs") (check check-source)) + (lint-checker + (name 'mirror-url) + (description "Suggest 'mirror://' URLs") + (check check-mirror-url)) (lint-checker (name 'source-file-name) (description "Validate file names of sources") diff --git a/tests/lint.scm b/tests/lint.scm index cf1b95ee69..0c534562a4 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -508,6 +508,25 @@ (check-source pkg)))) "not reachable: 404"))) +(test-assert "mirror-url" + (string-null? + (with-warnings + (let ((source (origin + (method url-fetch) + (uri "http://example.org/foo/bar.tar.gz") + (sha256 %null-sha256)))) + (check-mirror-url (dummy-package "x" (source source))))))) + +(test-assert "mirror-url: one suggestion" + (string-contains + (with-warnings + (let ((source (origin + (method url-fetch) + (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz") + (sha256 %null-sha256)))) + (check-mirror-url (dummy-package "x" (source source))))) + "mirror://gnu/foo/foo.tar.gz")) + (test-assert "cve" (mock ((guix scripts lint) package-vulnerabilities (const '())) (string-null? -- cgit v1.2.3