summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-10-12 23:26:50 +0200
committerLudovic Courtès <ludo@gnu.org>2017-10-12 23:47:48 +0200
commit61f28fe7e96e022055d3568956ed23c7a48e3548 (patch)
treef4c7e372772d5479e12ef40f717840ce4cf97951 /guix
parent6ea10db973d861cd8774938e40151c0f8b2d266f (diff)
downloadgnu-guix-61f28fe7e96e022055d3568956ed23c7a48e3548.tar
gnu-guix-61f28fe7e96e022055d3568956ed23c7a48e3548.tar.gz
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/lint.scm78
1 files changed, 54 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)))))