diff options
Diffstat (limited to 'guix/scripts/lint.scm')
| -rw-r--r-- | guix/scripts/lint.scm | 77 |
1 files changed, 70 insertions, 7 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..ddad5b7fd0 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,13 +1,14 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018, 2019 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 @@ -73,7 +76,9 @@ check-home-page check-source check-source-file-name + check-source-unstable-tarball check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -590,7 +595,8 @@ from ~a") 'home-page))))) (define %distro-directory - (dirname (search-path %load-path "gnu.scm"))) + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or if the @@ -615,12 +621,12 @@ patch could not be found." 'patch-file-names)) ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length %distro-directory)) + (let ((prefix (string-length (%distro-directory))) (margin (string-length "guix-0.13.0-10-123456789/")) (max 99)) (for-each (match-lambda ((? string? patch) - (when (> (+ margin (if (string-prefix? %distro-directory + (when (> (+ margin (if (string-prefix? (%distro-directory) patch) (- (string-length patch) prefix) (string-length patch))) @@ -748,6 +754,23 @@ descriptions maintained upstream." (G_ "the source file name should contain the package name") 'source)))) +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (when (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (emit-warning package + (G_ "the source URI should not be an autogenerated tarball") + 'source))) + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-source-uri uris))))) + (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." (define (check-mirror-uri uri) ;XXX: could be optimized @@ -773,16 +796,48 @@ 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) + (unless (string=? github-uri 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) (catch #t (lambda () - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") system - (nix-protocol-error-message c)))) + (store-protocol-error-message c)))) ((message-condition? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") @@ -1056,10 +1111,18 @@ or a list thereof") (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) + (lint-checker (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) + (lint-checker (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) |