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.

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