From a6e22d84450450cacc6fc36445f6ae378a5b7ad0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Oct 2017 10:22:43 +0200 Subject: ui: Improve reporting of missing closing parentheses. Suggested by Ricardo Wurmus. Works around . * guix/ui.scm (report-load-error): Add case for 'read-error'. * tests/guix-system.sh: Test missing-closing-paren errors. --- tests/guix-system.sh | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'tests') diff --git a/tests/guix-system.sh b/tests/guix-system.sh index d575795ea0..31ee637133 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -53,6 +53,21 @@ else fi +cat > "$tmpfile"< "$errorfile" +then + # This must not succeed. + exit 1 +else + grep "$tmpfile:4:1: missing closing paren" "$errorfile" +fi + + # Reporting of unbound variables. cat > "$tmpfile" < Date: Wed, 11 Oct 2017 15:14:16 +0200 Subject: zlib: Fix memory leak due to revealed ports not being GC'd. Fixes . This mostly reverts 81a0f1cdf12e7bcc34c1203f034a323fa8f52cf5, which introduced a regression: revealed ports are *never* GC'd (contrary to what Guile's manual suggests). In addition to the revert, 'close-procedure' now explicitly swallows EBADF errors when 'close-port' is called. * guix/zlib.scm (close-procedure): New procedure. (make-gzip-input-port)[gzfile]: Use 'fileno' instead of 'port->fdes'. Use 'close-procedure' instead of 'gzclose'. (make-gzip-output-port): Likewise. * tests/zlib.scm ("compression/decompression pipe"): Use 'port-closed?' to determine whether PARENT has been closed. --- guix/zlib.scm | 39 +++++++++++++++++++++++++++++---------- tests/zlib.scm | 11 +---------- 2 files changed, 30 insertions(+), 20 deletions(-) (limited to 'tests') diff --git a/guix/zlib.scm b/guix/zlib.scm index 3d830ef84e..955589ab48 100644 --- a/guix/zlib.scm +++ b/guix/zlib.scm @@ -149,6 +149,31 @@ the number of uncompressed bytes written, a strictly positive integer." ;; Z_DEFAULT_COMPRESSION. -1) +(define (close-procedure gzfile port) + "Return a procedure that closes GZFILE, ensuring its underlying PORT is +closed even if closing GZFILE triggers an exception." + (let-syntax ((ignore-EBADF + (syntax-rules () + ((_ exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (unless (= EBADF (system-error-errno args)) + (apply throw args)))))))) + + (lambda () + (catch 'zlib-error + (lambda () + ;; 'gzclose' closes the underlying file descriptor. 'close-port' + ;; calls close(2) and gets EBADF, which we swallow. + (gzclose gzfile) + (ignore-EBADF (close-port port))) + (lambda args + ;; Make sure PORT is closed despite the zlib error. + (ignore-EBADF (close-port port)) + (apply throw args)))))) + (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) "Return an input port that decompresses data read from PORT, a file port. PORT is automatically closed when the resulting port is closed. BUFFER-SIZE @@ -158,11 +183,7 @@ buffered input, which would be lost (and is lost anyway)." (define gzfile (match (drain-input port) ("" ;PORT's buffer is empty - ;; Since 'gzclose' will eventually close the file descriptor beneath - ;; PORT, we increase PORT's revealed count and never call 'close-port' - ;; on PORT since we would get EBADF if 'gzclose' already closed it (on - ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised). - (gzdopen (port->fdes port) "r")) + (gzdopen (fileno port) "r")) (_ ;; This is unrecoverable but it's better than having the buffered input ;; be lost, leading to unclear end-of-file or corrupt-data errors down @@ -177,8 +198,7 @@ buffered input, which would be lost (and is lost anyway)." (gzbuffer! gzfile buffer-size)) (make-custom-binary-input-port "gzip-input" read! #f #f - (lambda () - (gzclose gzfile)))) + (close-procedure gzfile port))) (define* (make-gzip-output-port port #:key @@ -190,7 +210,7 @@ port is closed." (define gzfile (begin (force-output port) ;empty PORT's buffer - (gzdopen (port->fdes port) + (gzdopen (fileno port) (string-append "w" (number->string level))))) (define (write! bv start count) @@ -200,8 +220,7 @@ port is closed." (gzbuffer! gzfile buffer-size)) (make-custom-binary-output-port "gzip-output" write! #f #f - (lambda () - (gzclose gzfile)))) + (close-procedure gzfile port))) (define* (call-with-gzip-input-port port proc #:key (buffer-size %default-buffer-size)) diff --git a/tests/zlib.scm b/tests/zlib.scm index f71609b7c5..5455240a71 100644 --- a/tests/zlib.scm +++ b/tests/zlib.scm @@ -57,16 +57,7 @@ (match (waitpid pid) ((_ . status) (and (zero? status) - - ;; PORT itself isn't closed but its underlying file - ;; descriptor must have been closed by 'gzclose'. - (catch 'system-error - (lambda () - (seek (fileno parent) 0 SEEK_CUR) - #f) - (lambda args - (= EBADF (system-error-errno args)))) - + (port-closed? parent) (bytevector=? received data)))))))))))) (test-end) -- cgit v1.2.3 From 6ea10db973d861cd8774938e40151c0f8b2d266f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Oct 2017 23:19:09 +0200 Subject: tests: Support multiple HTTP server instances. * guix/tests/http.scm (%http-server-socket): Turn into... (open-http-server-socket): ... this procedure. (http-server-can-listen?): New procedure. (http-write, %http-server-lock, %http-server-ready) (http-open, stub-http-server): Move to 'call-with-http-server' body. (call-with-http-server): Add #:headers parameter. (with-http-server): Add an additional pattern with headers. * tests/derivations.scm: Use (http-server-can-listen?) instead of (force %http-server-socket). * tests/lint.scm: Likewise. --- guix/tests/http.scm | 133 ++++++++++++++++++++++++++++---------------------- tests/derivations.scm | 8 +-- tests/lint.scm | 14 +++--- 3 files changed, 85 insertions(+), 70 deletions(-) (limited to 'tests') diff --git a/guix/tests/http.scm b/guix/tests/http.scm index fe1e120c5d..a56d6f213d 100644 --- a/guix/tests/http.scm +++ b/guix/tests/http.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,7 @@ #:export (with-http-server call-with-http-server %http-server-port - %http-server-socket + http-server-can-listen? %local-url)) ;;; Commentary: @@ -38,75 +38,85 @@ ;; TCP port to use for the stub HTTP server. (make-parameter 9999)) +(define (open-http-server-socket) + "Return a 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." + (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-server-can-listen?) + "Return #t if we managed to open a listening socket." + (and=> (open-http-server-socket) + (lambda (socket) + (close-port socket) + #t))) + (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))) +(define* (call-with-http-server code data thunk + #:key (headers '())) + "Call THUNK with an HTTP server running and returning CODE and DATA (a +string) on HTTP requests." + (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)) + ;; 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 (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-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") + #:reason-phrase "Such is life" + #:headers headers) data)) - (catch 'quit - (lambda () - (run-server handle stub-http-server - `(#:socket ,(force %http-server-socket)))) - (const #t))) + (let ((socket (open-http-server-socket))) + (catch 'quit + (lambda () + (run-server handle stub-http-server + `(#:socket ,socket))) + (lambda _ + (close-port socket))))) (with-mutex %http-server-lock (let ((server (make-thread server-body))) @@ -114,7 +124,12 @@ string) on HTTP requests." ;; 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-syntax with-http-server + (syntax-rules () + ((_ (code headers) data body ...) + (call-with-http-server code data (lambda () body ...) + #:headers headers)) + ((_ code data body ...) + (call-with-http-server code data (lambda () body ...))))) ;;; http.scm ends here diff --git a/tests/derivations.scm b/tests/derivations.scm index f3aad1b906..36afd42d05 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -222,7 +222,7 @@ (build-derivations %store (list drv)) #f))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder" (let ((text (random-text))) @@ -238,7 +238,7 @@ get-string-all) text)))))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, invalid hash" (with-http-server 200 "hello, world!" @@ -253,7 +253,7 @@ (build-derivations %store (list drv)) #f)))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, not found" (with-http-server 404 "not found" @@ -279,7 +279,7 @@ (build-derivations %store (list drv)) #f))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, check mode" ;; Make sure rebuilding the 'builtin:download' derivation in check mode diff --git a/tests/lint.scm b/tests/lint.scm index 7610a91fd3..d7254bc070 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -388,7 +388,7 @@ (check-home-page pkg))) "domain not found"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: Connection refused" (->bool (string-contains @@ -399,7 +399,7 @@ (check-home-page pkg))) "Connection refused"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" "" (with-warnings @@ -409,7 +409,7 @@ (home-page (%local-url))))) (check-home-page pkg))))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: 200 but short length" (->bool (string-contains @@ -421,7 +421,7 @@ (check-home-page pkg)))) "suspiciously small"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: 404" (->bool (string-contains @@ -510,7 +510,7 @@ (check-source-file-name pkg))) "file name should contain the package name")))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" "" (with-warnings @@ -523,7 +523,7 @@ (sha256 %null-sha256)))))) (check-source pkg))))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "source: 200 but short length" (->bool (string-contains @@ -538,7 +538,7 @@ (check-source pkg)))) "suspiciously small"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "source: 404" (->bool (string-contains -- cgit v1.2.3 From 61f28fe7e96e022055d3568956ed23c7a48e3548 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Oct 2017 23:26:50 +0200 Subject: lint: 'home-page' checker reports permanent redirects. * guix/scripts/lint.scm (probe-uri): Add special case for HTTP 301. (validate-uri): Likewise. * tests/lint.scm ("home-page: 301, invalid") ("home-page: 301 -> 200", "home-page: 301 -> 404") ("source: 301 -> 200", "source: 301 -> 404"): New tests. --- guix/scripts/lint.scm | 78 ++++++++++++++++++++++++++++++++--------------- tests/lint.scm | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 137 insertions(+), 24 deletions(-) (limited to 'tests') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index fc61f0b547..a26f92f49c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -414,8 +414,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (close-connection port)))) (case (response-code response) - ((301 ; moved permanently - 302 ; found (redirection) + ((302 ; found (redirection) 303 ; see other 307 ; temporary redirection 308) ; permanent redirection @@ -423,6 +422,22 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (if (or (not location) (member location visited)) (values 'http-response response) (loop location (cons location visited))))) ;follow the redirect + ((301) ; moved permanently + (let ((location (response-location response))) + ;; Return RESPONSE, unless the final response as we follow + ;; redirects is not 200. + (if location + (let-values (((status response2) + (loop location (cons location visited)))) + (case status + ((http-response) + (values 'http-response + (if (= 200 (response-code response2)) + response + response2))) + (else + (values status response2)))) + (values 'http-response response)))) ;invalid redirect (else (values 'http-response response))))) (lambda (key . args) @@ -474,31 +489,46 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (if (= 200 (response-code argument)) - (match (response-content-length argument) - ((? number? length) - ;; As of July 2016, SourceForge returns 200 (instead of 404) - ;; with a small HTML page upon failure. Attempt to detect such - ;; malicious behavior. - (or (> length 1000) + (cond ((= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect + ;; such malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (G_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t))) + ((= 301 (response-code argument)) + (if (response-location argument) (begin (emit-warning package - (format #f - (G_ "URI ~a returned \ -suspiciously small file (~a bytes)") + (format #f (G_ "permanent redirect from ~a to ~a") (uri->string uri) - length)) + (uri->string + (response-location argument)))) + #t) + (begin + (emit-warning package + (format #f (G_ "invalid permanent redirect \ +from ~a") + (uri->string uri))) #f))) - (_ #t)) - (begin - (emit-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - field) - #f))) + (else + (emit-warning package + (format #f + (G_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field) + #f))) ((ftp-response) (match argument (('ok) #t) @@ -534,7 +564,7 @@ suspiciously small file (~a bytes)") ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. #f) - ((unknown-protocol) ;nothing we can do + ((unknown-protocol) ;nothing we can do #f) (else (error "internal linter error" status))))) diff --git a/tests/lint.scm b/tests/lint.scm index d7254bc070..1d0fc4708c 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -37,6 +37,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) + #:use-module (web uri) #:use-module (web server) #:use-module (web server http) #:use-module (web response) @@ -433,6 +434,52 @@ (check-home-page pkg)))) "not reachable: 404"))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301, invalid" + (->bool + (string-contains + (with-warnings + (with-http-server 301 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg)))) + "invalid permanent redirect"))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301 -> 200" + (->bool + (string-contains + (with-warnings + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg))))))) + "permanent redirect"))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301 -> 404" + (->bool + (string-contains + (with-warnings + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg))))))) + "not reachable: 404"))) + (test-assert "source-file-name" (->bool (string-contains @@ -553,6 +600,42 @@ (check-source pkg)))) "not reachable: 404"))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 301 -> 200" + "" + (with-warnings + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (check-source pkg)))))))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "source: 301 -> 404" + (->bool + (string-contains + (with-warnings + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (check-source pkg))))))) + "not reachable: 404"))) + (test-assert "mirror-url" (string-null? (with-warnings -- cgit v1.2.3