From c10526672e515f07c92dc447bbc592808f67238e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 12 Jul 2020 22:41:09 +0200
Subject: [PATCH] lint: source: Validate URLs of Git references.

Until now the 'source' checker would look at URL for 'url-fetch' origins
but not for 'git-fetch' origins.

* guix/lint.scm (check-source): Add case for 'git-reference?'.
* tests/lint.scm ("source, git-reference: 301 -> 200"): New test.
---
 guix/lint.scm  | 45 +++++++++++++++++++++++++--------------------
 tests/lint.scm | 20 ++++++++++++++++++++
 2 files changed, 45 insertions(+), 20 deletions(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index 445c06f8f4..a550caa237 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -793,27 +793,32 @@ descriptions maintained upstream."
             (loop rest (cons warning warnings))))))))
 
   (let ((origin (package-source package)))
-    (if (and (origin? origin)
-             (eqv? (origin-method origin) url-fetch))
-        (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
-                                     (map string->uri (origin-uris origin))))
-               (warnings (warnings-for-uris uris)))
+    (if (origin? origin)
+        (cond
+         ((eq? (origin-method origin) url-fetch)
+          (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
+                                       (map string->uri (origin-uris origin))))
+                 (warnings (warnings-for-uris uris)))
 
-          ;; Just make sure that at least one of the URIs is valid.
-          (if (= (length uris) (length warnings))
-              ;; When everything fails, report all of WARNINGS, otherwise don't
-              ;; report anything.
-              ;;
-              ;; XXX: Ideally we'd still allow warnings to be raised if *some*
-              ;; URIs are unreachable, but distinguish that from the error case
-              ;; where *all* the URIs are unreachable.
-              (cons*
-               (make-warning package
-                             (G_ "all the source URIs are unreachable:")
-                             #:field 'source)
-               warnings)
-              '()))
-        '())))
+            ;; Just make sure that at least one of the URIs is valid.
+            (if (= (length uris) (length warnings))
+                ;; When everything fails, report all of WARNINGS, otherwise don't
+                ;; report anything.
+                ;;
+                ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+                ;; URIs are unreachable, but distinguish that from the error case
+                ;; where *all* the URIs are unreachable.
+                (cons*
+                 (make-warning package
+                               (G_ "all the source URIs are unreachable:")
+                               #:field 'source)
+                 warnings)
+                '())))
+         ((git-reference? (origin-uri origin))
+          (warnings-for-uris
+           (list (string->uri (git-reference-url (origin-uri origin))))))
+         (else
+          '())))))
 
 (define (check-source-file-name package)
   "Emit a warning if PACKAGE's origin has no meaningful file name."
diff --git a/tests/lint.scm b/tests/lint.scm
index ac174f9f23..83becb655a 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -697,6 +697,26 @@
                 (and (? lint-warning?) second-warning))
                (lint-warning-message second-warning)))))))))
 
+(test-skip (if (http-server-can-listen?) 0 1))
+(test-equal "source, git-reference: 301 -> 200"
+  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
+  (with-http-server `((200 ,%long-string))
+    (let* ((initial-url (%local-url))
+           (redirect    (build-response #:code 301
+                                        #:headers
+                                        `((location
+                                           . ,(string->uri initial-url))))))
+      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+        (with-http-server `((,redirect ""))
+          (let ((pkg (dummy-package
+                      "x"
+                      (source (origin
+                                (method git-fetch)
+                                (uri (git-reference (url (%local-url))
+                                                    (commit "v1.0.0")))
+                                (sha256 %null-sha256))))))
+            (single-lint-warning-message (check-source pkg))))))))
+
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 301 -> 404"
   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"