diff options
| -rw-r--r-- | guix/scripts/lint.scm | 78 | ||||
| -rw-r--r-- | tests/lint.scm | 83 |
2 files changed, 137 insertions, 24 deletions
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 |