nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2017-10-12 23:26:50 +02:00
parent 6ea10db973
commit 61f28fe7e9
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 137 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
guix/scripts/lint.scm
View File

@ -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,12 +489,12 @@ 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))
(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.
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
(begin
(emit-warning package
@ -489,8 +504,23 @@ suspiciously small file (~a bytes)")
(uri->string uri)
length))
#f)))
(_ #t))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
(begin
(emit-warning package
(format #f (G_ "permanent redirect from ~a to ~a")
(uri->string uri)
(uri->string
(response-location argument))))
#t)
(begin
(emit-warning package
(format #f (G_ "invalid permanent redirect \
from ~a")
(uri->string uri)))
#f)))
(else
(emit-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")

83
tests/lint.scm
View File

@ -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