diff options
| -rw-r--r-- | doc/guix.texi | 10 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 39 | ||||
| -rw-r--r-- | tests/lint.scm | 28 |
3 files changed, 73 insertions, 4 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 33f5c63420..484a29f2e1 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 +@itemx 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 -@code{file-name} (@pxref{origin Reference}). +invalid. Suggest a @code{mirror://} URL when applicable. If the +@code{source} 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 2314f3b28c..354f6f7031 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; 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 300153e24e..d4aa7c0e8e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; 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? |