01/01: guix: lint: Check for source URIs redirecting to GitHub.

[guix-commits]

arunisaac pushed a commit to branch master
in repository guix.

commit 0865d8a8f6c229fef5bcba647cc7b37c2f3d3dae
Author: Arun Isaac <address@hidden>
Date:   Fri Dec 21 17:48:55 2018 +0530

    guix: lint: Check for source URIs redirecting to GitHub.
    
    * guix/scripts/lint.scm (check-github-uri): New procedure.
    (%checkers): Add it.
    * doc/guix.texi (Invoking guix lint): Document it.
    * tests/lint.scm ("github-url", "github-url: one suggestion"): New tests.
---
 doc/guix.texi         | 10 ++++++----
 guix/scripts/lint.scm | 39 +++++++++++++++++++++++++++++++++++++++
 tests/lint.scm        | 28 ++++++++++++++++++++++++++++
 3 files changed, 73 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 33f5c63..484a29f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7660,12 +7660,14 @@ Identify inputs that should most likely be native 
inputs.
 @item source
 @itemx home-page
 @itemx mirror-url
address@hidden github-url
 @itemx source-file-name
 Probe @code{home-page} and @code{source} URLs and report those that are
-invalid.  Suggest a @code{mirror://} URL when applicable.  Check that
-the source file name is meaningful, e.g.@: is not
-just a version number or ``git-checkout'', without a declared
address@hidden (@pxref{origin Reference}).
+invalid.  Suggest a @code{mirror://} URL when applicable.  If the
address@hidden URL redirects to a GitHub URL, recommend usage of the GitHub
+URL.  Check that the source file name is meaningful, e.g.@: is not just a
+version number or ``git-checkout'', without a declared @code{file-name}
+(@pxref{origin Reference}).
 
 @item cve
 @cindex security vulnerabilities
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 2314f3b..354f6f7 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2017 Alex Kost <address@hidden>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <address@hidden>
 ;;; Copyright © 2017 Efraim Flashner <address@hidden>
+;;; Copyright © 2018 Arun Isaac <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -44,8 +45,10 @@
   #:use-module (guix cve)
   #:use-module (gnu packages)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
+  #:use-module (web client)
   #:use-module (web uri)
   #:use-module ((guix build download)
                 #:select (maybe-expand-mirrors
@@ -74,6 +77,7 @@
             check-source
             check-source-file-name
             check-mirror-url
+            check-github-url
             check-license
             check-vulnerabilities
             check-for-updates
@@ -773,6 +777,37 @@ descriptions maintained upstream."
       (let ((uris (origin-uris origin)))
         (for-each check-mirror-uri uris)))))
 
+(define (check-github-url package)
+  "Check whether PACKAGE uses source URLs that redirect to GitHub."
+  (define (follow-redirect uri)
+    (receive (response body) (http-head uri)
+      (case (response-code response)
+        ((301 302)
+         (uri->string (assoc-ref (response-headers response) 'location)))
+        (else #f))))
+
+  (define (follow-redirects-to-github uri)
+    (cond
+     ((string-prefix? "https://github.com/"; uri) uri)
+     ((string-prefix? "http" uri)
+      (and=> (follow-redirect uri) follow-redirects-to-github))
+     ;; Do not attempt to follow redirects on URIs other than http and https
+     ;; (such as mirror, file)
+     (else #f)))
+
+  (let ((origin (package-source package)))
+    (when (and (origin? origin)
+               (eqv? (origin-method origin) url-fetch))
+      (for-each
+       (lambda (uri)
+         (and=> (follow-redirects-to-github uri)
+                (lambda (github-uri)
+                  (emit-warning
+                   package
+                   (format #f (G_ "URL should be '~a'") github-uri)
+                   'source))))
+       (origin-uris origin)))))
+
 (define (check-derivation package)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
   (define (try system)
@@ -1056,6 +1091,10 @@ or a list thereof")
      (description "Suggest 'mirror://' URLs")
      (check       check-mirror-url))
    (lint-checker
+     (name        'github-uri)
+     (description "Suggest GitHub URIs")
+     (check       check-github-url))
+   (lint-checker
      (name        'source-file-name)
      (description "Validate file names of sources")
      (check       check-source-file-name))
diff --git a/tests/lint.scm b/tests/lint.scm
index 300153e..d4aa7c0 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2016 Hartmut Goebel <address@hidden>
 ;;; Copyright © 2017 Alex Kost <address@hidden>
 ;;; Copyright © 2017 Efraim Flashner <address@hidden>
+;;; Copyright © 2018 Arun Isaac <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -669,6 +670,33 @@
        (check-mirror-url (dummy-package "x" (source source)))))
    "mirror://gnu/foo/foo.tar.gz"))
 
+(test-assert "github-url"
+  (string-null?
+   (with-warnings
+     (with-http-server 200 %long-string
+       (check-github-url
+        (dummy-package "x" (source
+                            (origin
+                              (method url-fetch)
+                              (uri (%local-url))
+                              (sha256 %null-sha256)))))))))
+
+(let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz";))
+  (test-assert "github-url: one suggestion"
+    (string-contains
+     (with-warnings
+       (with-http-server (301 `((location . ,(string->uri github-url)))) ""
+         (let ((initial-uri (%local-url)))
+           (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+             (with-http-server (302 `((location . ,(string->uri 
initial-uri)))) ""
+               (check-github-url
+                (dummy-package "x" (source
+                                    (origin
+                                      (method url-fetch)
+                                      (uri (%local-url))
+                                      (sha256 %null-sha256))))))))))
+     github-url)))
+
 (test-assert "cve"
   (mock ((guix scripts lint) package-vulnerabilities (const '()))
         (string-null?