diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/lint.scm | 1222 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 1220 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/lint.scm | 2 |
5 files changed, 1244 insertions, 1202 deletions
diff --git a/Makefile.am b/Makefile.am index bb7156458c..b63c55d784 100644 --- a/Makefile.am +++ b/Makefile.am @@ -98,6 +98,7 @@ MODULES = \ guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/lint.scm \ guix/glob.scm \ guix/git.scm \ guix/graph.scm \ diff --git a/guix/lint.scm b/guix/lint.scm new file mode 100644 index 0000000000..c2c0914958 --- /dev/null +++ b/guix/lint.scm @@ -0,0 +1,1222 @@ +;;; 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, 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, 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix lint) + #:use-module ((guix store) #:hide (close-connection)) + #:use-module (guix base32) + #:use-module (guix diagnostics) + #:use-module (guix download) + #:use-module (guix ftp-client) + #:use-module (guix http-client) + #:use-module (guix packages) + #:use-module (guix i18n) + #:use-module (guix licenses) + #:use-module (guix records) + #:use-module (guix grafts) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix scripts) + #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) + #:use-module (guix gnu-maintenance) + #:use-module (guix monads) + #:use-module (guix cve) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #: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 + (open-connection-for-uri + . guix:open-connection-for-uri) + close-connection)) + #:use-module (web request) + #:use-module (web response) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) ;Unicode string ports + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 rdelim) + #:export (check-description-style + check-inputs-should-be-native + check-inputs-should-not-be-an-input-at-all + check-patch-file-names + check-synopsis-style + check-derivation + 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 + check-formatting + + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-message-text + lint-warning-message-data + lint-warning-location + + %checkers + + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) + + +;;; +;;; Warnings +;;; + +(define-record-type* <lint-warning> + lint-warning make-lint-warning + lint-warning? + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) + +(define (package-file package) + (location-file + (package-location package))) + +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) + (make-lint-warning + package + message-text + message-data + (or location + (package-field-location package field) + (package-location package)))) + +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)))) + + +;;; +;;; Checkers +;;; + +(define-record-type* <lint-checker> + lint-checker make-lint-checker + lint-checker? + ;; TODO: add a 'certainty' field that shows how confident we are in the + ;; checker. Then allow users to only run checkers that have a certain + ;; 'certainty' level. + (name lint-checker-name) + (description lint-checker-description) + (check lint-checker-check)) + +(define (properly-starts-sentence? s) + (string-match "^[(\"'`[:upper:][:digit:]]" s)) + +(define (starts-with-abbreviation? s) + "Return #t if S starts with what looks like an abbreviation or acronym." + (string-match "^[A-Z][A-Z0-9]+\\>" s)) + +(define %quoted-identifier-rx + ;; A quoted identifier, like 'this'. + (make-regexp "['`][[:graph:]]+'")) + +(define (check-description-style package) + ;; Emit a warning if stylistic issues are found in the description of PACKAGE. + (define (check-not-empty description) + (if (string-null? description) + (list + (make-warning package + (G_ "description should not be empty") + #:field 'description)) + '())) + + (define (check-texinfo-markup description) + "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of DESCRIPTION, otherwise #f." + (catch #t + (lambda () (texi->plain-text description)) + (lambda (keys . args) + (make-warning package + (G_ "Texinfo markup in description is invalid") + #:field 'description)))) + + (define (check-trademarks description) + "Check that DESCRIPTION does not contain '™' or '®' characters. See +http://www.gnu.org/prep/standards/html_node/Trademarks.html." + (match (string-index description (char-set #\™ #\®)) + ((and (? number?) index) + (list + (make-warning package + (G_ "description should not contain ~ +trademark sign '~a' at ~d") + (list (string-ref description index) index) + #:field 'description))) + (else '()))) + + (define (check-quotes description) + "Check whether DESCRIPTION contains single quotes and suggest @code." + (if (regexp-exec %quoted-identifier-rx description) + (list + (make-warning package + ;; TRANSLATORS: '@code' is Texinfo markup and must be kept + ;; as is. + (G_ "use @code or similar ornament instead of quotes") + #:field 'description)) + '())) + + (define (check-proper-start description) + (if (or (string-null? description) + (properly-starts-sentence? description) + (string-prefix-ci? (package-name package) description)) + '() + (list + (make-warning + package + (G_ "description should start with an upper-case letter or digit") + #:field 'description)))) + + (define (check-end-of-sentence-space description) + "Check that an end-of-sentence period is followed by two spaces." + (let ((infractions + (reverse (fold-matches + "\\. [A-Z]" description '() + (lambda (m r) + ;; Filter out matches of common abbreviations. + (if (find (lambda (s) + (string-suffix-ci? s (match:prefix m))) + '("i.e" "e.g" "a.k.a" "resp")) + r (cons (match:start m) r))))))) + (if (null? infractions) + '() + (list + (make-warning package + (G_ "sentences in description should be followed ~ +by two spaces; possible infraction~p at ~{~a~^, ~}") + (list (length infractions) + infractions) + #:field 'description))))) + + (let ((description (package-description package))) + (if (string? description) + (append + (check-not-empty description) + (check-quotes description) + (check-trademarks description) + ;; Use raw description for this because Texinfo rendering + ;; automatically fixes end of sentence space. + (check-end-of-sentence-space description) + (match (check-texinfo-markup description) + ((and warning (? lint-warning?)) (list warning)) + (plain-description + (check-proper-start plain-description)))) + (list + (make-warning package + (G_ "invalid description: ~s") + (list description) + #:field 'description))))) + +(define (package-input-intersection inputs-to-check input-names) + "Return the intersection between INPUTS-TO-CHECK, the list of input tuples +of a package, and INPUT-NAMES, a list of package specifications such as +\"glib:bin\"." + (match inputs-to-check + (((labels packages . outputs) ...) + (filter-map (lambda (package output) + (and (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (and (member input input-names) + input)))) + packages outputs)))) + +(define (check-inputs-should-be-native package) + ;; Emit a warning if some inputs of PACKAGE are likely to belong to its + ;; native inputs. + (let ((inputs (package-inputs package)) + (input-names + '("pkg-config" + "cmake" + "extra-cmake-modules" + "glib:bin" + "intltool" + "itstool" + "qttools" + "python-coverage" "python2-coverage" + "python-cython" "python2-cython" + "python-docutils" "python2-docutils" + "python-mock" "python2-mock" + "python-nose" "python2-nose" + "python-pbr" "python2-pbr" + "python-pytest" "python2-pytest" + "python-pytest-cov" "python2-pytest-cov" + "python-setuptools-scm" "python2-setuptools-scm" + "python-sphinx" "python2-sphinx"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably be a native input") + (list input) + #:field 'inputs)) + (package-input-intersection inputs input-names)))) + +(define (check-inputs-should-not-be-an-input-at-all package) + ;; Emit a warning if some inputs of PACKAGE are likely to should not be + ;; an input at all. + (let ((input-names '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably not be an input at all") + (list input) + #:field 'inputs)) + (package-input-intersection (package-direct-inputs package) + input-names)))) + +(define (package-name-regexp package) + "Return a regexp that matches PACKAGE's name as a word at the beginning of a +line." + (make-regexp (string-append "^" (regexp-quote (package-name package)) + "\\>") + regexp/icase)) + +(define (check-synopsis-style package) + ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. + (define (check-final-period synopsis) + ;; Synopsis should not end with a period, except for some special cases. + (if (and (string-suffix? "." synopsis) + (not (string-suffix? "etc." synopsis))) + (list + (make-warning package + (G_ "no period allowed at the end of the synopsis") + #:field 'synopsis)) + '())) + + (define check-start-article + ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to + ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>. + (if (false-if-exception (gnu-package? package)) + (const '()) + (lambda (synopsis) + (if (or (string-prefix-ci? "A " synopsis) + (string-prefix-ci? "An " synopsis)) + (list + (make-warning package + (G_ "no article allowed at the beginning of \ +the synopsis") + #:field 'synopsis)) + '())))) + + (define (check-synopsis-length synopsis) + (if (>= (string-length synopsis) 80) + (list + (make-warning package + (G_ "synopsis should be less than 80 characters long") + #:field 'synopsis)) + '())) + + (define (check-proper-start synopsis) + (if (properly-starts-sentence? synopsis) + '() + (list + (make-warning package + (G_ "synopsis should start with an upper-case letter or digit") + #:field 'synopsis)))) + + (define (check-start-with-package-name synopsis) + (if (and (regexp-exec (package-name-regexp package) synopsis) + (not (starts-with-abbreviation? synopsis))) + (list + (make-warning package + (G_ "synopsis should not start with the package name") + #:field 'synopsis)) + '())) + + (define (check-texinfo-markup synopsis) + "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of SYNOPSIS, otherwise #f." + (catch #t + (lambda () + (texi->plain-text synopsis) + '()) + (lambda (keys . args) + (list + (make-warning package + (G_ "Texinfo markup in synopsis is invalid") + #:field 'synopsis))))) + + (define checks + (list check-proper-start + check-final-period + check-start-article + check-start-with-package-name + check-synopsis-length + check-texinfo-markup)) + + (match (package-synopsis package) + ("" + (list + (make-warning package + (G_ "synopsis should not be empty") + #:field 'synopsis))) + ((? string? synopsis) + (append-map + (lambda (proc) + (proc synopsis)) + checks)) + (invalid + (list + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) + #:field 'synopsis))))) + +(define* (probe-uri uri #:key timeout) + "Probe URI, a URI object, and return two values: a symbol denoting the +probing status, such as 'http-response' when we managed to get an HTTP +response from URI, and additional details, such as the actual HTTP response. + +TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait +for connections to complete; when TIMEOUT is #f, wait as long as needed." + (define headers + '((User-Agent . "GNU Guile") + (Accept . "*/*"))) + + (let loop ((uri uri) + (visited '())) + (match (uri-scheme uri) + ((or 'http 'https) + (catch #t + (lambda () + (let ((port (guix:open-connection-for-uri + uri #:timeout timeout)) + (request (build-request uri #:headers headers))) + (define response + (dynamic-wind + (const #f) + (lambda () + (write-request request port) + (force-output port) + (read-response port)) + (lambda () + (close-connection port)))) + + (case (response-code response) + ((302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection + (let ((location (response-location response))) + (if (or (not location) (member location visited)) + (values 'http-response response) + (loop location (cons location visited))))) ;follow the redirect + ((301) ; moved permanently + (let ((location (response-location response))) + ;; Return RESPONSE, unless the final response as we follow + ;; redirects is not 200. + (if location + (let-values (((status response2) + (loop location (cons location visited)))) + (case status + ((http-response) + (values 'http-response + (if (= 200 (response-code response2)) + response + response2))) + (else + (values status response2)))) + (values 'http-response response)))) ;invalid redirect + (else + (values 'http-response response))))) + (lambda (key . args) + (case key + ((bad-header bad-header-component) + ;; This can happen if the server returns an invalid HTTP header, + ;; as is the case with the 'Date' header at sqlite.org. + (values 'invalid-http-response #f)) + ((getaddrinfo-error system-error + gnutls-error tls-certificate-error) + (values key args)) + (else + (apply throw key args)))))) + ('ftp + (catch #t + (lambda () + (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) + (define response + (dynamic-wind + (const #f) + (lambda () + (ftp-chdir conn (dirname (uri-path uri))) + (ftp-size conn (basename (uri-path uri)))) + (lambda () + (ftp-close conn)))) + (values 'ftp-response '(ok)))) + (lambda (key . args) + (case key + ((ftp-error) + (values 'ftp-response `(error ,@args))) + ((getaddrinfo-error system-error gnutls-error) + (values key args)) + (else + (apply throw key args)))))) + (_ + (values 'unknown-protocol #f))))) + +(define (tls-certificate-error-string args) + "Return a string explaining the 'tls-certificate-error' arguments ARGS." + (call-with-output-string + (lambda (port) + (print-exception port #f + 'tls-certificate-error args)))) + +(define (validate-uri uri package field) + "Return #t if the given URI can be reached, otherwise return a warning for +PACKAGE mentionning the FIELD." + (let-values (((status argument) + (probe-uri uri #:timeout 3))) ;wait at most 3 seconds + (case status + ((http-response) + (cond ((= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect + ;; such malicious behavior. + (or (> length 1000) + (make-warning package + (G_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (list (uri->string uri) + length) + #:field field))) + (_ #t))) + ((= 301 (response-code argument)) + (if (response-location argument) + (make-warning package + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) + #:field field) + (make-warning package + (G_ "invalid permanent redirect \ +from ~a") + (list (uri->string uri)) + #:field field))) + (else + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + #:field field)))) + ((ftp-response) + (match argument + (('ok) #t) + (('error port command code message) + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) + #:field field)))) + ((getaddrinfo-error) + (make-warning package + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) + #:field field)) + ((system-error) + (make-warning package + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) + #:field field)) + ((tls-certificate-error) + (make-warning package + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) + #:field field)) + ((invalid-http-response gnutls-error) + ;; Probably a misbehaving server; ignore. + #f) + ((unknown-protocol) ;nothing we can do + #f) + (else + (error "internal linter error" status))))) + +(define (check-home-page package) + "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that +'home-page' is not reachable." + (let ((uri (and=> (package-home-page package) string->uri))) + (cond + ((uri? uri) + (match (validate-uri uri package 'home-page) + ((and (? lint-warning? warning) warning) + (list warning)) + (_ '()))) + ((not (package-home-page package)) + (if (or (string-contains (package-name package) "bootstrap") + (string=? (package-name package) "ld-wrapper")) + '() + (list + (make-warning package + (G_ "invalid value for home page") + #:field 'home-page)))) + (else + (list + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) + #:field 'home-page)))))) + +(define %distro-directory + (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 +patch could not be found." + (guard (c ((message-condition? c) ;raised by 'search-patch' + (list + ;; Use %make-warning, as condition-mesasge is already + ;; translated. + (%make-warning package (condition-message c) + #:field 'patch-file-names)))) + (define patches + (or (and=> (package-source package) origin-patches) + '())) + + (append + (if (every (match-lambda ;patch starts with package name? + ((? string? patch) + (and=> (string-contains (basename patch) + (package-name package)) + zero?)) + (_ #f)) ;must be an <origin> or something like that. + patches) + '() + (list + (make-warning + package + (G_ "file names of patches should start with the package name") + #:field 'patch-file-names))) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length (%distro-directory))) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (filter-map (match-lambda + ((? string? patch) + (if (> (+ margin (if (string-prefix? (%distro-directory) + patch) + (- (string-length patch) prefix) + (string-length patch))) + max) + (make-warning + package + (G_ "~a: file name is too long") + (list (basename patch)) + #:field 'patch-file-names) + #f)) + (_ #f)) + patches))))) + +(define (escape-quotes str) + "Replace any quote character in STR by an escaped quote character." + (list->string + (string-fold-right (lambda (chr result) + (match chr + (#\" (cons* #\\ #\"result)) + (_ (cons chr result)))) + '() + str))) + +(define official-gnu-packages* + (mlambda () + "A memoizing version of 'official-gnu-packages' that returns the empty +list when something goes wrong, such as a networking issue." + (let ((gnus (false-if-exception (official-gnu-packages)))) + (or gnus '())))) + +(define (check-gnu-synopsis+description package) + "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and +descriptions maintained upstream." + (match (find (lambda (descriptor) + (string=? (gnu-package-name descriptor) + (package-name package))) + (official-gnu-packages*)) + (#f ;not a GNU package, so nothing to do + '()) + (descriptor ;a genuine GNU package + (append + (let ((upstream (gnu-package-doc-summary descriptor)) + (downstream (package-synopsis package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? upstream downstream)))) + (list + (make-warning package + (G_ "proposed synopsis: ~s~%") + (list upstream) + #:field 'synopsis)) + '())) + + (let ((upstream (gnu-package-doc-description descriptor)) + (downstream (package-description package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? (fill-paragraph upstream 100) + (fill-paragraph downstream 100))))) + (list + (make-warning + package + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) + #:field 'description)) + '())))))) + +(define (origin-uris origin) + "Return the list of URIs (strings) for ORIGIN." + (match (origin-uri origin) + ((? string? uri) + (list uri)) + ((uris ...) + uris))) + +(define (check-source package) + "Emit a warning if PACKAGE has an invalid 'source' field, or if that +'source' is not reachable." + (define (warnings-for-uris uris) + (filter lint-warning? + (map + (lambda (uri) + (validate-uri uri package 'source)) + (append-map (cut maybe-expand-mirrors <> %mirrors) + uris)))) + + (let ((origin (package-source package))) + (if (and origin + (eqv? (origin-method origin) url-fetch)) + (let* ((uris (map string->uri (origin-uris origin))) + (warnings (warnings-for-uris uris))) + + ;; Just make sure that at least one of the URIs is valid. + (if (eq? (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) + '())) + '()))) + +(define (check-source-file-name package) + "Emit a warning if PACKAGE's origin has no meaningful file name." + (define (origin-file-name-valid? origin) + ;; Return #f if the source file name contains only a version or is #f; + ;; indicates that the origin needs a 'file-name' field. + (let ((file-name (origin-actual-file-name origin)) + (version (package-version package))) + (and file-name + ;; Common in many projects is for the filename to start + ;; with a "v" followed by the version, + ;; e.g. "v3.2.0.tar.gz". + (not (string-match (string-append "^v?" version) file-name))))) + + (let ((origin (package-source package))) + (if (or (not origin) (origin-file-name-valid? origin)) + '() + (list + (make-warning package + (G_ "the source file name should contain the package name") + #:field 'source))))) + +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (if (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (make-warning package + (G_ "the source URI should not be an autogenerated tarball") + #:field 'source) + #f)) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map check-source-uri + (origin-uris origin)) + '()))) + +(define (check-mirror-url package) + "Check whether PACKAGE uses source URLs that should be 'mirror://'." + (define (check-mirror-uri uri) ;XXX: could be optimized + (let loop ((mirrors %mirrors)) + (match mirrors + (() + #f) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (make-warning package + (G_ "URL should be \ +'mirror://~a/~a'") + (list mirror-id + (string-drop uri (string-length prefix))) + #:field 'source))))))) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (filter-map check-mirror-uri uris)) + '()))) + +(define* (check-github-url package #:key (timeout 3)) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) + (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))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (if (string=? github-uri uri) + #f + (make-warning + package + (G_ "URL should be '~a'") + (list github-uri) + #:field '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 ((store-protocol-error? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) + ((message-condition? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f))))))) + (lambda args + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system args))))) + + (filter lint-warning? + (map try (package-supported-systems package)))) + +(define (check-license package) + "Warn about type errors of the 'license' field of PACKAGE." + (match (package-license package) + ((or (? license?) + ((? license?) ...)) + '()) + (x + (list + (make-warning package (G_ "invalid license field") + #:field 'license))))) + +(define (call-with-networking-fail-safe message error-value proc) + "Call PROC catching any network-related errors. Upon a networking error, +display a message including MESSAGE and return ERROR-VALUE." + (guard (c ((http-get-error? c) + (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") + message + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + error-value)) + (catch #t + proc + (match-lambda* + (('getaddrinfo-error errcode) + (warning (G_ "~a: host lookup failure: ~a~%") + message + (gai-strerror errcode)) + error-value) + (('tls-certificate-error args ...) + (warning (G_ "~a: TLS certificate error: ~a") + message + (tls-certificate-error-string args)) + error-value) + (args + (apply throw args)))))) + +(define-syntax-rule (with-networking-fail-safe message error-value exp ...) + (call-with-networking-fail-safe message error-value + (lambda () exp ...))) + +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal." + (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") + '() + (current-vulnerabilities))) + +(define package-vulnerabilities + (let ((lookup (delay (vulnerabilities->lookup-proc + (current-vulnerabilities*))))) + (lambda (package) + "Return a list of vulnerabilities affecting PACKAGE." + ;; First we retrieve the Common Platform Enumeration (CPE) name and + ;; version for PACKAGE, then we can pass them to LOOKUP. + (let ((name (or (assoc-ref (package-properties package) + 'cpe-name) + (package-name package))) + (version (or (assoc-ref (package-properties package) + 'cpe-version) + (package-version package)))) + ((force lookup) name version))))) + +(define (check-vulnerabilities package) + "Check for known vulnerabilities for PACKAGE." + (let ((package (or (package-replacement package) package))) + (match (package-vulnerabilities package) + (() + '()) + ((vulnerabilities ...) + (let* ((patched (package-patched-vulnerabilities package)) + (known-safe (or (assq-ref (package-properties package) + 'lint-hidden-cve) + '())) + (unpatched (remove (lambda (vuln) + (let ((id (vulnerability-id vuln))) + (or (member id patched) + (member id known-safe)))) + vulnerabilities))) + (if (null? unpatched) + '() + (list + (make-warning + package + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) + +(define (check-for-updates package) + "Check if there is an update available for PACKAGE." + (match (with-networking-fail-safe + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) + #f + (package-latest-release* package (force %updaters))) + ((? upstream-source? source) + (if (version>? (upstream-source-version source) + (package-version package)) + (list + (make-warning package + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) + #:field 'version)) + '())) + (#f '()))) ; cannot find newer upstream release + + +;;; +;;; Source code formatting. +;;; + +(define (report-tabulations package line line-number) + "Warn about tabulations found in LINE." + (match (string-index line #\tab) + (#f #t) + (index + (make-warning package + (G_ "tabulation on line ~a, column ~a") + (list line-number index) + #:location + (location (package-file package) + line-number + index))))) + +(define (report-trailing-white-space package line line-number) + "Warn about trailing white space in LINE." + (unless (or (string=? line (string-trim-right line)) + (string=? line (string #\page))) + (make-warning package + (G_ "trailing white space on line ~a") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define (report-long-line package line line-number) + "Emit a warning if LINE is too long." + ;; Note: We don't warn at 80 characters because sometimes hashes and URLs + ;; make it hard to fit within that limit and we want to avoid making too + ;; much noise. + (when (> (string-length line) 90) + (make-warning package + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) + #:location + (location (package-file package) + line-number + 0)))) + +(define %hanging-paren-rx + (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) + +(define (report-lone-parentheses package line line-number) + "Emit a warning if LINE contains hanging parentheses." + (when (regexp-exec %hanging-paren-rx line) + (make-warning package + (G_ "parentheses feel lonely, \ +move to the previous or next line") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define %formatting-reporters + ;; List of procedures that report formatting issues. These are not separate + ;; checkers because they would need to re-read the file. + (list report-tabulations + report-trailing-white-space + report-long-line + report-lone-parentheses)) + +(define* (report-formatting-issues package file starting-line + #:key (reporters %formatting-reporters)) + "Report white-space issues in FILE starting from STARTING-LINE, and report +them for PACKAGE." + (define (sexp-last-line port) + ;; Return the last line of the sexp read from PORT or an estimate thereof. + (define &failure (list 'failure)) + + (let ((start (ftell port)) + (start-line (port-line port)) + (sexp (catch 'read-error + (lambda () (read port)) + (const &failure)))) + (let ((line (port-line port))) + (seek port start SEEK_SET) + (set-port-line! port start-line) + (if (eq? sexp &failure) + (+ start-line 60) ;conservative estimate + line)))) + + (call-with-input-file file + (lambda (port) + (let loop ((line-number 1) + (last-line #f) + (warnings '())) + (let ((line (read-line port))) + (if (or (eof-object? line) + (and last-line (> line-number last-line))) + warnings + (if (and (= line-number starting-line) + (not last-line)) + (loop (+ 1 line-number) + (+ 1 (sexp-last-line port)) + warnings) + (loop (+ 1 line-number) + last-line + (append + warnings + (if (< line-number starting-line) + '() + (filter + lint-warning? + (map (lambda (report) + (report package line line-number)) + reporters)))))))))))) + +(define (check-formatting package) + "Check the formatting of the source code of PACKAGE." + (let ((location (package-location package))) + (if location + (and=> (search-path %load-path (location-file location)) + (lambda (file) + ;; Report issues starting from the line before the 'package' + ;; form, which usually contains the 'define' form. + (report-formatting-issues package file + (- (location-line location) 1)))) + '()))) + + +;;; +;;; List of checkers. +;;; + +(define %checkers + (list + (lint-checker + (name 'description) + (description "Validate package descriptions") + (check check-description-style)) + (lint-checker + (name 'gnu-description) + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker + (name 'inputs-should-be-native) + (description "Identify inputs that should be native inputs") + (check check-inputs-should-be-native)) + (lint-checker + (name 'inputs-should-not-be-input) + (description "Identify inputs that shouldn't be inputs at all") + (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) + (lint-checker + (name 'home-page) + (description "Validate home-page URLs") + (check check-home-page)) + (lint-checker + (name 'license) + ;; TRANSLATORS: <license> is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a <license> \ +or a list thereof") + (check check-license)) + (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker + (name 'mirror-url) + (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)) + (lint-checker + (name 'synopsis) + (description "Validate package synopses") + (check check-synopsis-style)) + (lint-checker + (name 'cve) + (description "Check the Common Vulnerabilities and Exposures\ + (CVE) database") + (check check-vulnerabilities)) + (lint-checker + (name 'refresh) + (description "Check the package for new upstream releases") + (check check-for-updates)) + (lint-checker + (name 'formatting) + (description "Look for formatting issues in the source") + (check check-formatting)))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4eb7e0e200..1c46fba16b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -26,1224 +26,32 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) - #:use-module ((guix store) #:hide (close-connection)) - #:use-module (guix base32) - #:use-module (guix download) - #:use-module (guix ftp-client) - #:use-module (guix http-client) #:use-module (guix packages) - #:use-module (guix licenses) - #:use-module (guix records) - #:use-module (guix grafts) + #:use-module (guix lint) #:use-module (guix ui) - #:use-module (guix upstream) - #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix scripts) - #:use-module (guix gnu-maintenance) - #:use-module (guix monads) - #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #: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 - (open-connection-for-uri - . guix:open-connection-for-uri) - close-connection)) - #:use-module (web request) - #:use-module (web response) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-6) ;Unicode string ports - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (ice-9 rdelim) #:export (guix-lint - check-description-style - check-inputs-should-be-native - check-inputs-should-not-be-an-input-at-all - check-patch-file-names - check-synopsis-style - check-derivation - 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 - check-formatting - run-checkers - - lint-warning - lint-warning? - lint-warning-package - lint-warning-message - lint-warning-message-text - lint-warning-message-data - lint-warning-location - - %checkers - lint-checker - lint-checker? - lint-checker-name - lint-checker-description - lint-checker-check)) - - -;;; -;;; Warnings -;;; - -(define-record-type* <lint-warning> - lint-warning make-lint-warning - lint-warning? - (package lint-warning-package) - (message-text lint-warning-message-text) - (message-data lint-warning-message-data - (default '())) - (location lint-warning-location - (default #f))) - -(define (lint-warning-message warning) - (apply format #f - (G_ (lint-warning-message-text warning)) - (lint-warning-message-data warning))) - -(define (package-file package) - (location-file - (package-location package))) - -(define* (%make-warning package message-text - #:optional (message-data '()) - #:key field location) - (make-lint-warning - package - message-text - message-data - (or location - (package-field-location package field) - (package-location package)))) - -(define-syntax make-warning - (syntax-rules (G_) - ((_ package (G_ message) rest ...) - (%make-warning package message rest ...)))) + run-checkers)) (define (emit-warnings warnings) ;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; provided MESSAGE. (for-each - (match-lambda - (($ <lint-warning> package message-text message-data loc) - (format (guix-warning-port) "~a: ~a@~a: ~a~%" - (location->string loc) - (package-name package) (package-version package) - (apply format #f (G_ message-text) message-data)))) + (lambda (lint-warning) + (let ((package (lint-warning-package lint-warning)) + (loc (lint-warning-location lint-warning))) + (format (guix-warning-port) "~a: ~a@~a: ~a~%" + (location->string loc) + (package-name package) (package-version package) + (lint-warning-message lint-warning)))) warnings)) - -;;; -;;; Checkers -;;; - -(define-record-type* <lint-checker> - lint-checker make-lint-checker - lint-checker? - ;; TODO: add a 'certainty' field that shows how confident we are in the - ;; checker. Then allow users to only run checkers that have a certain - ;; 'certainty' level. - (name lint-checker-name) - (description lint-checker-description) - (check lint-checker-check)) - -(define (list-checkers-and-exit) - ;; Print information about all available checkers and exit. - (format #t (G_ "Available checkers:~%")) - (for-each (lambda (checker) - (format #t "- ~a: ~a~%" - (lint-checker-name checker) - (G_ (lint-checker-description checker)))) - %checkers) - (exit 0)) - -(define (properly-starts-sentence? s) - (string-match "^[(\"'`[:upper:][:digit:]]" s)) - -(define (starts-with-abbreviation? s) - "Return #t if S starts with what looks like an abbreviation or acronym." - (string-match "^[A-Z][A-Z0-9]+\\>" s)) - -(define %quoted-identifier-rx - ;; A quoted identifier, like 'this'. - (make-regexp "['`][[:graph:]]+'")) - -(define (check-description-style package) - ;; Emit a warning if stylistic issues are found in the description of PACKAGE. - (define (check-not-empty description) - (if (string-null? description) - (list - (make-warning package - (G_ "description should not be empty") - #:field 'description)) - '())) - - (define (check-texinfo-markup description) - "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of DESCRIPTION, otherwise #f." - (catch #t - (lambda () (texi->plain-text description)) - (lambda (keys . args) - (make-warning package - (G_ "Texinfo markup in description is invalid") - #:field 'description)))) - - (define (check-trademarks description) - "Check that DESCRIPTION does not contain '™' or '®' characters. See -http://www.gnu.org/prep/standards/html_node/Trademarks.html." - (match (string-index description (char-set #\™ #\®)) - ((and (? number?) index) - (list - (make-warning package - (G_ "description should not contain ~ -trademark sign '~a' at ~d") - (list (string-ref description index) index) - #:field 'description))) - (else '()))) - - (define (check-quotes description) - "Check whether DESCRIPTION contains single quotes and suggest @code." - (if (regexp-exec %quoted-identifier-rx description) - (list - (make-warning package - ;; TRANSLATORS: '@code' is Texinfo markup and must be kept - ;; as is. - (G_ "use @code or similar ornament instead of quotes") - #:field 'description)) - '())) - - (define (check-proper-start description) - (if (or (string-null? description) - (properly-starts-sentence? description) - (string-prefix-ci? (package-name package) description)) - '() - (list - (make-warning - package - (G_ "description should start with an upper-case letter or digit") - #:field 'description)))) - - (define (check-end-of-sentence-space description) - "Check that an end-of-sentence period is followed by two spaces." - (let ((infractions - (reverse (fold-matches - "\\. [A-Z]" description '() - (lambda (m r) - ;; Filter out matches of common abbreviations. - (if (find (lambda (s) - (string-suffix-ci? s (match:prefix m))) - '("i.e" "e.g" "a.k.a" "resp")) - r (cons (match:start m) r))))))) - (if (null? infractions) - '() - (list - (make-warning package - (G_ "sentences in description should be followed ~ -by two spaces; possible infraction~p at ~{~a~^, ~}") - (list (length infractions) - infractions) - #:field 'description))))) - - (let ((description (package-description package))) - (if (string? description) - (append - (check-not-empty description) - (check-quotes description) - (check-trademarks description) - ;; Use raw description for this because Texinfo rendering - ;; automatically fixes end of sentence space. - (check-end-of-sentence-space description) - (match (check-texinfo-markup description) - ((and warning (? lint-warning?)) (list warning)) - (plain-description - (check-proper-start plain-description)))) - (list - (make-warning package - (G_ "invalid description: ~s") - (list description) - #:field 'description))))) - -(define (package-input-intersection inputs-to-check input-names) - "Return the intersection between INPUTS-TO-CHECK, the list of input tuples -of a package, and INPUT-NAMES, a list of package specifications such as -\"glib:bin\"." - (match inputs-to-check - (((labels packages . outputs) ...) - (filter-map (lambda (package output) - (and (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (and (member input input-names) - input)))) - packages outputs)))) - -(define (check-inputs-should-be-native package) - ;; Emit a warning if some inputs of PACKAGE are likely to belong to its - ;; native inputs. - (let ((inputs (package-inputs package)) - (input-names - '("pkg-config" - "cmake" - "extra-cmake-modules" - "glib:bin" - "intltool" - "itstool" - "qttools" - "python-coverage" "python2-coverage" - "python-cython" "python2-cython" - "python-docutils" "python2-docutils" - "python-mock" "python2-mock" - "python-nose" "python2-nose" - "python-pbr" "python2-pbr" - "python-pytest" "python2-pytest" - "python-pytest-cov" "python2-pytest-cov" - "python-setuptools-scm" "python2-setuptools-scm" - "python-sphinx" "python2-sphinx"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably be a native input") - (list input) - #:field 'inputs)) - (package-input-intersection inputs input-names)))) - -(define (check-inputs-should-not-be-an-input-at-all package) - ;; Emit a warning if some inputs of PACKAGE are likely to should not be - ;; an input at all. - (let ((input-names '("python-setuptools" - "python2-setuptools" - "python-pip" - "python2-pip"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably not be an input at all") - (list input) - #:field 'inputs)) - (package-input-intersection (package-direct-inputs package) - input-names)))) - -(define (package-name-regexp package) - "Return a regexp that matches PACKAGE's name as a word at the beginning of a -line." - (make-regexp (string-append "^" (regexp-quote (package-name package)) - "\\>") - regexp/icase)) - -(define (check-synopsis-style package) - ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. - (define (check-final-period synopsis) - ;; Synopsis should not end with a period, except for some special cases. - (if (and (string-suffix? "." synopsis) - (not (string-suffix? "etc." synopsis))) - (list - (make-warning package - (G_ "no period allowed at the end of the synopsis") - #:field 'synopsis)) - '())) - - (define check-start-article - ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to - ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>. - (if (false-if-exception (gnu-package? package)) - (const '()) - (lambda (synopsis) - (if (or (string-prefix-ci? "A " synopsis) - (string-prefix-ci? "An " synopsis)) - (list - (make-warning package - (G_ "no article allowed at the beginning of \ -the synopsis") - #:field 'synopsis)) - '())))) - - (define (check-synopsis-length synopsis) - (if (>= (string-length synopsis) 80) - (list - (make-warning package - (G_ "synopsis should be less than 80 characters long") - #:field 'synopsis)) - '())) - - (define (check-proper-start synopsis) - (if (properly-starts-sentence? synopsis) - '() - (list - (make-warning package - (G_ "synopsis should start with an upper-case letter or digit") - #:field 'synopsis)))) - - (define (check-start-with-package-name synopsis) - (if (and (regexp-exec (package-name-regexp package) synopsis) - (not (starts-with-abbreviation? synopsis))) - (list - (make-warning package - (G_ "synopsis should not start with the package name") - #:field 'synopsis)) - '())) - - (define (check-texinfo-markup synopsis) - "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of SYNOPSIS, otherwise #f." - (catch #t - (lambda () - (texi->plain-text synopsis) - '()) - (lambda (keys . args) - (list - (make-warning package - (G_ "Texinfo markup in synopsis is invalid") - #:field 'synopsis))))) - - (define checks - (list check-proper-start - check-final-period - check-start-article - check-start-with-package-name - check-synopsis-length - check-texinfo-markup)) - - (match (package-synopsis package) - ("" - (list - (make-warning package - (G_ "synopsis should not be empty") - #:field 'synopsis))) - ((? string? synopsis) - (append-map - (lambda (proc) - (proc synopsis)) - checks)) - (invalid - (list - (make-warning package - (G_ "invalid synopsis: ~s") - (list invalid) - #:field 'synopsis))))) - -(define* (probe-uri uri #:key timeout) - "Probe URI, a URI object, and return two values: a symbol denoting the -probing status, such as 'http-response' when we managed to get an HTTP -response from URI, and additional details, such as the actual HTTP response. - -TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait -for connections to complete; when TIMEOUT is #f, wait as long as needed." - (define headers - '((User-Agent . "GNU Guile") - (Accept . "*/*"))) - - (let loop ((uri uri) - (visited '())) - (match (uri-scheme uri) - ((or 'http 'https) - (catch #t - (lambda () - (let ((port (guix:open-connection-for-uri - uri #:timeout timeout)) - (request (build-request uri #:headers headers))) - (define response - (dynamic-wind - (const #f) - (lambda () - (write-request request port) - (force-output port) - (read-response port)) - (lambda () - (close-connection port)))) - - (case (response-code response) - ((302 ; found (redirection) - 303 ; see other - 307 ; temporary redirection - 308) ; permanent redirection - (let ((location (response-location response))) - (if (or (not location) (member location visited)) - (values 'http-response response) - (loop location (cons location visited))))) ;follow the redirect - ((301) ; moved permanently - (let ((location (response-location response))) - ;; Return RESPONSE, unless the final response as we follow - ;; redirects is not 200. - (if location - (let-values (((status response2) - (loop location (cons location visited)))) - (case status - ((http-response) - (values 'http-response - (if (= 200 (response-code response2)) - response - response2))) - (else - (values status response2)))) - (values 'http-response response)))) ;invalid redirect - (else - (values 'http-response response))))) - (lambda (key . args) - (case key - ((bad-header bad-header-component) - ;; This can happen if the server returns an invalid HTTP header, - ;; as is the case with the 'Date' header at sqlite.org. - (values 'invalid-http-response #f)) - ((getaddrinfo-error system-error - gnutls-error tls-certificate-error) - (values key args)) - (else - (apply throw key args)))))) - ('ftp - (catch #t - (lambda () - (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) - (define response - (dynamic-wind - (const #f) - (lambda () - (ftp-chdir conn (dirname (uri-path uri))) - (ftp-size conn (basename (uri-path uri)))) - (lambda () - (ftp-close conn)))) - (values 'ftp-response '(ok)))) - (lambda (key . args) - (case key - ((ftp-error) - (values 'ftp-response `(error ,@args))) - ((getaddrinfo-error system-error gnutls-error) - (values key args)) - (else - (apply throw key args)))))) - (_ - (values 'unknown-protocol #f))))) - -(define (tls-certificate-error-string args) - "Return a string explaining the 'tls-certificate-error' arguments ARGS." - (call-with-output-string - (lambda (port) - (print-exception port #f - 'tls-certificate-error args)))) - -(define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise return a warning for -PACKAGE mentionning the FIELD." - (let-values (((status argument) - (probe-uri uri #:timeout 3))) ;wait at most 3 seconds - (case status - ((http-response) - (cond ((= 200 (response-code argument)) - (match (response-content-length argument) - ((? number? length) - ;; As of July 2016, SourceForge returns 200 (instead of 404) - ;; with a small HTML page upon failure. Attempt to detect - ;; such malicious behavior. - (or (> length 1000) - (make-warning package - (G_ "URI ~a returned \ -suspiciously small file (~a bytes)") - (list (uri->string uri) - length) - #:field field))) - (_ #t))) - ((= 301 (response-code argument)) - (if (response-location argument) - (make-warning package - (G_ "permanent redirect from ~a to ~a") - (list (uri->string uri) - (uri->string - (response-location argument))) - #:field field) - (make-warning package - (G_ "invalid permanent redirect \ -from ~a") - (list (uri->string uri)) - #:field field))) - (else - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - #:field field)))) - ((ftp-response) - (match argument - (('ok) #t) - (('error port command code message) - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - code (string-trim-both message)) - #:field field)))) - ((getaddrinfo-error) - (make-warning package - (G_ "URI ~a domain not found: ~a") - (list (uri->string uri) - (gai-strerror (car argument))) - #:field field)) - ((system-error) - (make-warning package - (G_ "URI ~a unreachable: ~a") - (list (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) - #:field field)) - ((tls-certificate-error) - (make-warning package - (G_ "TLS certificate error: ~a") - (list (tls-certificate-error-string argument)) - #:field field)) - ((invalid-http-response gnutls-error) - ;; Probably a misbehaving server; ignore. - #f) - ((unknown-protocol) ;nothing we can do - #f) - (else - (error "internal linter error" status))))) - -(define (check-home-page package) - "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that -'home-page' is not reachable." - (let ((uri (and=> (package-home-page package) string->uri))) - (cond - ((uri? uri) - (match (validate-uri uri package 'home-page) - ((and (? lint-warning? warning) warning) - (list warning)) - (_ '()))) - ((not (package-home-page package)) - (if (or (string-contains (package-name package) "bootstrap") - (string=? (package-name package) "ld-wrapper")) - '() - (list - (make-warning package - (G_ "invalid value for home page") - #:field 'home-page)))) - (else - (list - (make-warning package - (G_ "invalid home page URL: ~s") - (list (package-home-page package)) - #:field 'home-page)))))) - -(define %distro-directory - (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 -patch could not be found." - (guard (c ((message-condition? c) ;raised by 'search-patch' - (list - ;; Use %make-warning, as condition-mesasge is already - ;; translated. - (%make-warning package (condition-message c) - #:field 'patch-file-names)))) - (define patches - (or (and=> (package-source package) origin-patches) - '())) - - (append - (if (every (match-lambda ;patch starts with package name? - ((? string? patch) - (and=> (string-contains (basename patch) - (package-name package)) - zero?)) - (_ #f)) ;must be an <origin> or something like that. - patches) - '() - (list - (make-warning - package - (G_ "file names of patches should start with the package name") - #:field 'patch-file-names))) - - ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-0.13.0-10-123456789/")) - (max 99)) - (filter-map (match-lambda - ((? string? patch) - (if (> (+ margin (if (string-prefix? (%distro-directory) - patch) - (- (string-length patch) prefix) - (string-length patch))) - max) - (make-warning - package - (G_ "~a: file name is too long") - (list (basename patch)) - #:field 'patch-file-names) - #f)) - (_ #f)) - patches))))) - -(define (escape-quotes str) - "Replace any quote character in STR by an escaped quote character." - (list->string - (string-fold-right (lambda (chr result) - (match chr - (#\" (cons* #\\ #\"result)) - (_ (cons chr result)))) - '() - str))) - -(define official-gnu-packages* - (mlambda () - "A memoizing version of 'official-gnu-packages' that returns the empty -list when something goes wrong, such as a networking issue." - (let ((gnus (false-if-exception (official-gnu-packages)))) - (or gnus '())))) - -(define (check-gnu-synopsis+description package) - "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and -descriptions maintained upstream." - (match (find (lambda (descriptor) - (string=? (gnu-package-name descriptor) - (package-name package))) - (official-gnu-packages*)) - (#f ;not a GNU package, so nothing to do - '()) - (descriptor ;a genuine GNU package - (append - (let ((upstream (gnu-package-doc-summary descriptor)) - (downstream (package-synopsis package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? upstream downstream)))) - (list - (make-warning package - (G_ "proposed synopsis: ~s~%") - (list upstream) - #:field 'synopsis)) - '())) - - (let ((upstream (gnu-package-doc-description descriptor)) - (downstream (package-description package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? (fill-paragraph upstream 100) - (fill-paragraph downstream 100))))) - (list - (make-warning - package - (G_ "proposed description:~% \"~a\"~%") - (list (fill-paragraph (escape-quotes upstream) 77 7)) - #:field 'description)) - '())))))) - -(define (origin-uris origin) - "Return the list of URIs (strings) for ORIGIN." - (match (origin-uri origin) - ((? string? uri) - (list uri)) - ((uris ...) - uris))) - -(define (check-source package) - "Emit a warning if PACKAGE has an invalid 'source' field, or if that -'source' is not reachable." - (define (warnings-for-uris uris) - (filter lint-warning? - (map - (lambda (uri) - (validate-uri uri package 'source)) - (append-map (cut maybe-expand-mirrors <> %mirrors) - uris)))) - - (let ((origin (package-source package))) - (if (and origin - (eqv? (origin-method origin) url-fetch)) - (let* ((uris (map string->uri (origin-uris origin))) - (warnings (warnings-for-uris uris))) - - ;; Just make sure that at least one of the URIs is valid. - (if (eq? (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) - '())) - '()))) - -(define (check-source-file-name package) - "Emit a warning if PACKAGE's origin has no meaningful file name." - (define (origin-file-name-valid? origin) - ;; Return #f if the source file name contains only a version or is #f; - ;; indicates that the origin needs a 'file-name' field. - (let ((file-name (origin-actual-file-name origin)) - (version (package-version package))) - (and file-name - ;; Common in many projects is for the filename to start - ;; with a "v" followed by the version, - ;; e.g. "v3.2.0.tar.gz". - (not (string-match (string-append "^v?" version) file-name))))) - - (let ((origin (package-source package))) - (if (or (not origin) (origin-file-name-valid? origin)) - '() - (list - (make-warning package - (G_ "the source file name should contain the package name") - #:field 'source))))) - -(define (check-source-unstable-tarball package) - "Emit a warning if PACKAGE's source is an autogenerated tarball." - (define (check-source-uri uri) - (if (and (string=? (uri-host (string->uri uri)) "github.com") - (match (split-and-decode-uri-path - (uri-path (string->uri uri))) - ((_ _ "archive" _ ...) #t) - (_ #f))) - (make-warning package - (G_ "the source URI should not be an autogenerated tarball") - #:field 'source) - #f)) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map check-source-uri - (origin-uris origin)) - '()))) - -(define (check-mirror-url package) - "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (let ((uris (origin-uris origin))) - (filter-map check-mirror-uri uris)) - '()))) - -(define* (check-github-url package #:key (timeout 3)) - "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect url) - (let* ((uri (string->uri url)) - (port (guix:open-connection-for-uri uri #:timeout timeout)) - (response (http-head uri #:port port))) - (close-port port) - (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))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map - (lambda (uri) - (and=> (follow-redirects-to-github uri) - (lambda (github-uri) - (if (string=? github-uri uri) - #f - (make-warning - package - (G_ "URL should be '~a'") - (list github-uri) - #:field '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 ((store-protocol-error? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (store-protocol-error-message c)))) - ((message-condition? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement system - #:graft? #f))))))) - (lambda args - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system args))))) - - (filter lint-warning? - (map try (package-supported-systems package)))) - -(define (check-license package) - "Warn about type errors of the 'license' field of PACKAGE." - (match (package-license package) - ((or (? license?) - ((? license?) ...)) - '()) - (x - (list - (make-warning package (G_ "invalid license field") - #:field 'license))))) - -(define (call-with-networking-fail-safe message error-value proc) - "Call PROC catching any network-related errors. Upon a networking error, -display a message including MESSAGE and return ERROR-VALUE." - (guard (c ((http-get-error? c) - (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") - message - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - error-value)) - (catch #t - proc - (match-lambda* - (('getaddrinfo-error errcode) - (warning (G_ "~a: host lookup failure: ~a~%") - message - (gai-strerror errcode)) - error-value) - (('tls-certificate-error args ...) - (warning (G_ "~a: TLS certificate error: ~a") - message - (tls-certificate-error-string args)) - error-value) - (args - (apply throw args)))))) - -(define-syntax-rule (with-networking-fail-safe message error-value exp ...) - (call-with-networking-fail-safe message error-value - (lambda () exp ...))) - -(define (current-vulnerabilities*) - "Like 'current-vulnerabilities', but return the empty list upon networking -or HTTP errors. This allows network-less operation and makes problems with -the NIST server non-fatal." - (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") - '() - (current-vulnerabilities))) - -(define package-vulnerabilities - (let ((lookup (delay (vulnerabilities->lookup-proc - (current-vulnerabilities*))))) - (lambda (package) - "Return a list of vulnerabilities affecting PACKAGE." - ;; First we retrieve the Common Platform Enumeration (CPE) name and - ;; version for PACKAGE, then we can pass them to LOOKUP. - (let ((name (or (assoc-ref (package-properties package) - 'cpe-name) - (package-name package))) - (version (or (assoc-ref (package-properties package) - 'cpe-version) - (package-version package)))) - ((force lookup) name version))))) - -(define (check-vulnerabilities package) - "Check for known vulnerabilities for PACKAGE." - (let ((package (or (package-replacement package) package))) - (match (package-vulnerabilities package) - (() - '()) - ((vulnerabilities ...) - (let* ((patched (package-patched-vulnerabilities package)) - (known-safe (or (assq-ref (package-properties package) - 'lint-hidden-cve) - '())) - (unpatched (remove (lambda (vuln) - (let ((id (vulnerability-id vuln))) - (or (member id patched) - (member id known-safe)))) - vulnerabilities))) - (if (null? unpatched) - '() - (list - (make-warning - package - (G_ "probably vulnerable to ~a") - (list (string-join (map vulnerability-id unpatched) - ", ")))))))))) - -(define (check-for-updates package) - "Check if there is an update available for PACKAGE." - (match (with-networking-fail-safe - (G_ "while retrieving upstream info for '~a'") - (list (package-name package)) - #f - (package-latest-release* package (force %updaters))) - ((? upstream-source? source) - (if (version>? (upstream-source-version source) - (package-version package)) - (list - (make-warning package - (G_ "can be upgraded to ~a") - (list (upstream-source-version source)) - #:field 'version)) - '())) - (#f '()))) ; cannot find newer upstream release - - -;;; -;;; Source code formatting. -;;; - -(define (report-tabulations package line line-number) - "Warn about tabulations found in LINE." - (match (string-index line #\tab) - (#f #t) - (index - (make-warning package - (G_ "tabulation on line ~a, column ~a") - (list line-number index) - #:location - (location (package-file package) - line-number - index))))) - -(define (report-trailing-white-space package line line-number) - "Warn about trailing white space in LINE." - (unless (or (string=? line (string-trim-right line)) - (string=? line (string #\page))) - (make-warning package - (G_ "trailing white space on line ~a") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define (report-long-line package line line-number) - "Emit a warning if LINE is too long." - ;; Note: We don't warn at 80 characters because sometimes hashes and URLs - ;; make it hard to fit within that limit and we want to avoid making too - ;; much noise. - (when (> (string-length line) 90) - (make-warning package - (G_ "line ~a is way too long (~a characters)") - (list line-number (string-length line)) - #:location - (location (package-file package) - line-number - 0)))) - -(define %hanging-paren-rx - (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) - -(define (report-lone-parentheses package line line-number) - "Emit a warning if LINE contains hanging parentheses." - (when (regexp-exec %hanging-paren-rx line) - (make-warning package - (G_ "parentheses feel lonely, \ -move to the previous or next line") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define %formatting-reporters - ;; List of procedures that report formatting issues. These are not separate - ;; checkers because they would need to re-read the file. - (list report-tabulations - report-trailing-white-space - report-long-line - report-lone-parentheses)) - -(define* (report-formatting-issues package file starting-line - #:key (reporters %formatting-reporters)) - "Report white-space issues in FILE starting from STARTING-LINE, and report -them for PACKAGE." - (define (sexp-last-line port) - ;; Return the last line of the sexp read from PORT or an estimate thereof. - (define &failure (list 'failure)) - - (let ((start (ftell port)) - (start-line (port-line port)) - (sexp (catch 'read-error - (lambda () (read port)) - (const &failure)))) - (let ((line (port-line port))) - (seek port start SEEK_SET) - (set-port-line! port start-line) - (if (eq? sexp &failure) - (+ start-line 60) ;conservative estimate - line)))) - - (call-with-input-file file - (lambda (port) - (let loop ((line-number 1) - (last-line #f) - (warnings '())) - (let ((line (read-line port))) - (if (or (eof-object? line) - (and last-line (> line-number last-line))) - warnings - (if (and (= line-number starting-line) - (not last-line)) - (loop (+ 1 line-number) - (+ 1 (sexp-last-line port)) - warnings) - (loop (+ 1 line-number) - last-line - (append - warnings - (if (< line-number starting-line) - '() - (filter - lint-warning? - (map (lambda (report) - (report package line line-number)) - reporters)))))))))))) - -(define (check-formatting package) - "Check the formatting of the source code of PACKAGE." - (let ((location (package-location package))) - (if location - (and=> (search-path %load-path (location-file location)) - (lambda (file) - ;; Report issues starting from the line before the 'package' - ;; form, which usually contains the 'define' form. - (report-formatting-issues package file - (- (location-line location) 1)))) - '()))) - - -;;; -;;; List of checkers. -;;; - -(define %checkers - (list - (lint-checker - (name 'description) - (description "Validate package descriptions") - (check check-description-style)) - (lint-checker - (name 'gnu-description) - (description "Validate synopsis & description of GNU packages") - (check check-gnu-synopsis+description)) - (lint-checker - (name 'inputs-should-be-native) - (description "Identify inputs that should be native inputs") - (check check-inputs-should-be-native)) - (lint-checker - (name 'inputs-should-not-be-input) - (description "Identify inputs that shouldn't be inputs at all") - (check check-inputs-should-not-be-an-input-at-all)) - (lint-checker - (name 'patch-file-names) - (description "Validate file names and availability of patches") - (check check-patch-file-names)) - (lint-checker - (name 'home-page) - (description "Validate home-page URLs") - (check check-home-page)) - (lint-checker - (name 'license) - ;; TRANSLATORS: <license> is the name of a data type and must not be - ;; translated. - (description "Make sure the 'license' field is a <license> \ -or a list thereof") - (check check-license)) - (lint-checker - (name 'source) - (description "Validate source URLs") - (check check-source)) - (lint-checker - (name 'mirror-url) - (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)) - (lint-checker - (name 'synopsis) - (description "Validate package synopses") - (check check-synopsis-style)) - (lint-checker - (name 'cve) - (description "Check the Common Vulnerabilities and Exposures\ - (CVE) database") - (check check-vulnerabilities)) - (lint-checker - (name 'refresh) - (description "Check the package for new upstream releases") - (check check-for-updates)) - (lint-checker - (name 'formatting) - (description "Look for formatting issues in the source") - (check check-formatting)))) - (define* (run-checkers package #:optional (checkers %checkers)) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) @@ -1260,6 +68,16 @@ or a list thereof") (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) +(define (list-checkers-and-exit) + ;; Print information about all available checkers and exit. + (format #t (G_ "Available checkers:~%")) + (for-each (lambda (checker) + (format #t "- ~a: ~a~%" + (lint-checker-name checker) + (G_ (lint-checker-description checker)))) + %checkers) + (exit 0)) + ;;; ;;; Command-line options. diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index ad06ebce95..8b556ac0ec 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -40,6 +40,7 @@ gnu/machine/ssh.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm +guix/lint.scm guix/scripts/download.scm guix/scripts/package.scm guix/scripts/install.scm diff --git a/tests/lint.scm b/tests/lint.scm index d8b2ca54cd..59be061a99 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -33,7 +33,7 @@ #:use-module (guix git-download) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (guix scripts lint) + #:use-module (guix lint) #:use-module (guix ui) #:use-module (gnu packages) #:use-module (gnu packages glib) |