From 61f28fe7e96e022055d3568956ed23c7a48e3548 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 12 Oct 2017 23:26:50 +0200
Subject: 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.
---
 tests/lint.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)

(limited to 'tests')

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
-- 
cgit v1.2.3