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.
master
Ludovic Courtès
parent
6ea10db973
commit
61f28fe7e9
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue