aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/scripts/lint.scm78
-rw-r--r--tests/lint.scm83
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