;;; 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 © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;; 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 store)
#:use-module (guix base32)
#:use-module (guix diagnostics)
#:use-module (guix download)
#: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 ((guix swh) #:hide (origin?))
+ #:autoload (guix git-download) (git-reference?
+ git-reference-url git-reference-commit)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module ((guix build download)
#:select (maybe-expand-mirrors
(open-connection-for-uri
- . guix:open-connection-for-uri)
- close-connection))
+ . guix:open-connection-for-uri)))
#:use-module (web request)
#:use-module (web response)
#:use-module (srfi srfi-1)
check-vulnerabilities
check-for-updates
check-formatting
+ check-archival
lint-warning
lint-warning?
lint-warning-message-data
lint-warning-location
- %checkers
+ %local-checkers
+ %network-dependent-checkers
+ %all-checkers
lint-checker
lint-checker?
lint-checker-name
lint-checker-description
- lint-checker-check))
+ lint-checker-check
+ lint-checker-requires-store?))
\f
;;;
;; 'certainty' level.
(name lint-checker-name)
(description lint-checker-description)
- (check lint-checker-check))
+ (check lint-checker-check)
+ (requires-store? lint-checker-requires-store?
+ (default #f)))
(define (properly-starts-sentence? s)
(string-match "^[(\"'`[:upper:][:digit:]]" s))
(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))
+ (let ((inputs (append (package-inputs package)
+ (package-propagated-inputs package)))
(input-names
'("pkg-config"
+ "autoconf"
+ "automake"
+ "bison"
"cmake"
+ "dejagnu"
+ "desktop-file-utils"
+ "doxygen"
"extra-cmake-modules"
+ "flex"
+ "gettext"
"glib:bin"
+ "gobject-introspection"
+ "googletest-source"
+ "groff"
+ "gtk-doc"
+ "help2man"
"intltool"
"itstool"
+ "libtool"
+ "m4"
"qttools"
+ "yasm" "nasm" "fasm"
"python-coverage" "python2-coverage"
"python-cython" "python2-cython"
"python-docutils" "python2-docutils"
"python-pytest" "python2-pytest"
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
- "python-sphinx" "python2-sphinx")))
+ "python-sphinx" "python2-sphinx"
+ "scdoc"
+ "swig"
+ "qmake"
+ "qttools"
+ "texinfo"
+ "xorg-server-for-tests"
+ "yelp-tools")))
(map (lambda (input)
(make-warning
package
(force-output port)
(read-response port))
(lambda ()
- (close-connection port))))
+ (close-port port))))
(case (response-code response)
((302 ; found (redirection)
(define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise return a warning for
-PACKAGE mentionning the FIELD."
+PACKAGE mentioning the FIELD."
(let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
;; 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/"))
+ (margin (string-length "guix-2.0.0rc3-10000-1234567890/"))
(max 99))
(filter-map (match-lambda
((? string? patch)
"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 loop ((uris uris)
+ (warnings '()))
+ (match uris
+ (()
+ (reverse warnings))
+ ((uri rest ...)
+ (match (validate-uri uri package 'source)
+ (#t
+ ;; We found a working URL, so stop right away.
+ '())
+ ((? lint-warning? warning)
+ (loop rest (cons warning warnings))))))))
(let ((origin (package-source package)))
(if (and origin
(eqv? (origin-method origin) url-fetch))
- (let* ((uris (map string->uri (origin-uris origin)))
+ (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 (eq? (length uris) (length warnings))
+ (if (= (length uris) (length warnings))
;; When everything fails, report all of WARNINGS, otherwise don't
;; report anything.
;;
(origin-uris origin))
'())))
-(define (check-derivation package)
+(cond-expand
+ (guile-3
+ ;; Guile 3.0.0 does not export this predicate.
+ (define exception-with-kind-and-args?
+ (exception-predicate &exception-with-kind-and-args)))
+ (else ;Guile 2
+ (define exception-with-kind-and-args?
+ (const #f))))
+
+(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."
- (define (try system)
- (catch #t
+ (define (try store system)
+ (catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported.
(lambda ()
(guard (c ((store-protocol-error? c)
(make-warning package
(G_ "failed to create ~a derivation: ~a")
(list system
(store-protocol-error-message c))))
+ ((exception-with-kind-and-args? c)
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~s")
+ (list system
+ (cons (exception-kind c)
+ (exception-args 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)))))))
+ (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-with-store store)
+ (filter lint-warning?
+ (map (cut try store <>) (package-supported-systems package))))
+
+ ;; For backwards compatability, don't rely on store being set
+ (or (and=> store check-with-store)
+ (with-store store
+ (check-with-store store))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
message
(tls-certificate-error-string args))
error-value)
+ ((and ('system-error _ ...) args)
+ (let ((errno (system-error-errno args)))
+ (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
+ (let ((details (call-with-output-string
+ (lambda (port)
+ (print-exception port #f (car args)
+ (cdr args))))))
+ (warning (G_ "~a: ~a~%") message details)
+ error-value)
+ (apply throw args))))
(args
(apply throw args))))))
(package-version package))))
((force lookup) name version)))))
-(define (check-vulnerabilities package)
- "Check for known vulnerabilities for PACKAGE."
+(define* (check-vulnerabilities package
+ #:optional (package-vulnerabilities
+ package-vulnerabilities))
+ "Check for known vulnerabilities for PACKAGE. Obtain the list of
+vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES."
(let ((package (or (package-replacement package) package)))
(match (package-vulnerabilities package)
(()
(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))
+ (format #f (G_ "while retrieving upstream info for '~a'")
+ (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
'()))
(#f '()))) ; cannot find newer upstream release
+
+(define (check-archival package)
+ "Check whether PACKAGE's source code is archived on Software Heritage. If
+it's not, and if its source code is a VCS snapshot, then send a \"save\"
+request to Software Heritage.
+
+Software Heritage imposes limits on the request rate per client IP address.
+This checker prints a notice and stops doing anything once that limit has been
+reached."
+ (define (response->warning url method response)
+ (if (request-rate-limit-reached? url method)
+ (list (make-warning package
+ (G_ "Software Heritage rate limit reached; \
+try again later")
+ #:field 'source))
+ (list (make-warning package
+ (G_ "'~a' returned ~a")
+ (list url (response-code response))
+ #:field 'source))))
+
+ (define skip-key (gensym "skip-archival-check"))
+
+ (define (skip-when-limit-reached url method)
+ (or (not (request-rate-limit-reached? url method))
+ (throw skip-key #t)))
+
+ (parameterize ((%allow-request? skip-when-limit-reached))
+ (catch #t
+ (lambda ()
+ (match (and (origin? (package-source package))
+ (package-source package))
+ (#f ;no source
+ '())
+ ((= origin-uri (? git-reference? reference))
+ (define url
+ (git-reference-url reference))
+ (define commit
+ (git-reference-commit reference))
+
+ (match (if (commit-id? commit)
+ (or (lookup-revision commit)
+ (lookup-origin-revision url commit))
+ (lookup-origin-revision url commit))
+ ((? revision? revision)
+ '())
+ (#f
+ ;; Revision is missing from the archive, attempt to save it.
+ (catch 'swh-error
+ (lambda ()
+ (save-origin (git-reference-url reference) "git")
+ (list (make-warning
+ package
+ ;; TRANSLATORS: "Software Heritage" is a proper noun
+ ;; that must remain untranslated. See
+ ;; <https://www.softwareheritage.org>.
+ (G_ "scheduled Software Heritage archival")
+ #:field 'source)))
+ (lambda (key url method response . _)
+ (cond ((= 429 (response-code response))
+ (list (make-warning
+ package
+ (G_ "archival rate limit exceeded; \
+try again later")
+ #:field 'source)))
+ (else
+ (response->warning url method response))))))))
+ ((? origin? origin)
+ ;; Since "save" origins are not supported for non-VCS source, all
+ ;; we can do is tell whether a given tarball is available or not.
+ (if (origin-sha256 origin) ;XXX: for ungoogled-chromium
+ (match (lookup-content (origin-sha256 origin) "sha256")
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
+Heritage")
+ #:field 'source)))
+ ((? content?)
+ '()))
+ '()))))
+ (match-lambda*
+ ((key url method response)
+ (response->warning url method response))
+ ((key . args)
+ (if (eq? key skip-key)
+ '()
+ (with-networking-fail-safe
+ (G_ "while connecting to Software Heritage")
+ '()
+ (apply throw key args))))))))
+
\f
;;;
;;; Source code formatting.
(define (report-tabulations package line line-number)
"Warn about tabulations found in LINE."
(match (string-index line #\tab)
- (#f #t)
+ (#f #f)
(index
(make-warning package
(G_ "tabulation on line ~a, column ~a")
(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))))
+ (and (not (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))))
+ (and (> (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, \
+ (and (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))))
+ (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
warnings
(if (< line-number starting-line)
'()
- (filter
- lint-warning?
- (map (lambda (report)
- (report package line line-number))
- reporters))))))))))))
+ (filter-map (lambda (report)
+ (report package line line-number))
+ reporters)))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
;;; List of checkers.
;;;
-(define %checkers
+(define %local-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")
(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
(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")
(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))
+ (name 'derivation)
+ (description "Report failure to compile a package to a derivation")
+ (check check-derivation)
+ (requires-store? #t))
+ (lint-checker
+ (name 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
+
+(define %network-dependent-checkers
+ (list
(lint-checker
(name 'synopsis)
(description "Validate package synopses")
(check check-synopsis-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
(lint-checker
(name 'cve)
(description "Check the Common Vulnerabilities and Exposures\
(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))))
+ (name 'archival)
+ (description "Ensure source code archival on Software Heritage")
+ (check check-archival))))
+
+(define %all-checkers
+ (append %local-checkers
+ %network-dependent-checkers))
HCoop / jackhill / guix / guix.git / blobdiff