;;; 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, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix http-client)
#:use-module (guix packages)
#:use-module (guix i18n)
+ #:use-module ((guix gexp)
+ #:select (local-file? local-file-absolute-file-name))
#:use-module (guix licenses)
#:use-module (guix records)
#:use-module (guix grafts)
#:use-module ((guix swh) #:hide (origin?))
#:autoload (guix git-download) (git-reference?
git-reference-url git-reference-commit)
+ #:use-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
check-inputs-should-be-native
check-inputs-should-not-be-an-input-at-all
check-patch-file-names
+ check-patch-headers
check-synopsis-style
check-derivation
check-home-page
+ check-name
check-source
check-source-file-name
check-source-unstable-tarball
check-formatting
check-archival
check-profile-collisions
+ check-haskell-stackage
lint-warning
lint-warning?
message-text
message-data
(or location
- (package-field-location package field)
+ (and field (package-field-location package field))
(package-location package))))
(define-syntax make-warning
(requires-store? lint-checker-requires-store?
(default #f)))
+(define (check-name package)
+ "Check whether PACKAGE's name matches our guidelines."
+ (let ((name (package-name package)))
+ (cond
+ ;; Currently checks only whether the name is too short.
+ ((and (<= (string-length name) 1)
+ (not (string=? name "r"))) ; common-sense exception
+ (list
+ (make-warning package
+ (G_ "name should be longer than a single character")
+ #:field 'name)))
+ ((string-index name #\_)
+ (list
+ (make-warning package
+ (G_ "name should use hyphens instead of underscores")
+ #:field 'name)))
+ (else '()))))
+
(define (properly-starts-sentence? s)
(string-match "^[(\"'`[:upper:][:digit:]]" s))
(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))))
+ (guard (c ((formatted-message? c) ;raised by 'search-patch'
+ (list (%make-warning package
+ (formatted-message-string c)
+ (formatted-message-arguments c)
+ #:field 'source))))
(define patches
- (or (and=> (package-source package) origin-patches)
- '()))
+ (match (package-source package)
+ ((? origin? origin) (origin-patches origin))
+ (_ '())))
(define (starts-with-package-name? file-name)
(and=> (string-contains file-name (package-name package))
(_ #f))
patches)))))
+(define (check-patch-headers package)
+ "Check that PACKAGE's patches start with a comment. Return a list of
+warnings."
+ (define (blank? str)
+ (string-every char-set:blank str))
+
+ (define (patch-header-warnings patch)
+ (call-with-input-file patch
+ (lambda (port)
+ ;; Read from PORT until a non-blank line is found or EOF is reached.
+ (let loop ()
+ (let ((line (read-line port)))
+ (cond ((eof-object? line)
+ (list (make-warning package
+ (G_ "~a: empty patch")
+ (list (basename patch))
+ #:field 'source)))
+ ((blank? line)
+ (loop))
+ ((or (string-prefix? "--- " line)
+ (string-prefix? "+++ " line))
+ (list (make-warning package
+ (G_ "~a: patch lacks comment and \
+upstream status")
+ (list (basename patch))
+ #:field 'source)))
+ (else
+ '())))))))
+
+ (guard (c ((formatted-message? c) ;raised by 'search-patch'
+ (list (%make-warning package
+ (formatted-message-string c)
+ (formatted-message-arguments c)
+ #:field 'source))))
+ (let ((patches (if (origin? (package-source package))
+ (origin-patches (package-source package))
+ '())))
+ (append-map (lambda (patch)
+ ;; Dismiss PATCH if it's an origin or similar.
+ (cond ((string? patch)
+ (patch-header-warnings patch))
+ ((local-file? patch)
+ (patch-header-warnings
+ (local-file-absolute-file-name patch)))
+ (else
+ '())))
+ patches))))
+
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
(list->string
(#t
;; We found a working URL, so stop right away.
'())
+ (#f
+ ;; Unsupported URL or other error, skip.
+ (loop rest warnings))
((? lint-warning? warning)
(loop rest (cons warning warnings))))))))
(let ((origin (package-source package)))
- (if (and origin
- (eqv? (origin-method origin) url-fetch))
- (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 (= (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)
- '()))
+ (if (origin? origin)
+ (cond
+ ((eq? (origin-method origin) url-fetch)
+ (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 (= (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)
+ '())))
+ ((git-reference? (origin-uri origin))
+ (warnings-for-uris
+ (list (string->uri (git-reference-url (origin-uri origin))))))
+ (else
+ '()))
'())))
(define (check-source-file-name package)
(not (string-match (string-append "^v?" version) file-name)))))
(let ((origin (package-source package)))
- (if (or (not origin) (origin-file-name-valid? origin))
+ (if (or (not (origin? origin)) (origin-file-name-valid? origin))
'()
(list
(make-warning package
(make-warning package
(G_ "failed to create ~a derivation: ~a")
(list system
- (condition-message c)))))
+ (condition-message c))))
+ ((formatted-message? c)
+ (let ((str (apply format #f
+ (formatted-message-string c)
+ (formatted-message-arguments c))))
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~a")
+ (list system str)))))
(parameterize ((%graft? #f))
(package-derivation store package system #:graft? #f)
the NIST server non-fatal."
(with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
'()
- (current-vulnerabilities)))
+ (current-vulnerabilities #:timeout 4)))
(define package-vulnerabilities
(let ((lookup (delay (vulnerabilities->lookup-proc
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
- (match (with-networking-fail-safe
- (format #f (G_ "while retrieving upstream info for '~a'")
- (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
+ (match (lookup-updater package)
+ (#f
+ (list (make-warning package (G_ "no updater for ~a")
+ (list (package-name package))
+ #:field 'source)))
+ ((? upstream-updater? updater)
+ (match (with-networking-fail-safe
+ (format #f (G_ "while retrieving upstream info for '~a'")
+ (package-name package))
+ #f
+ (package-latest-release package))
+ ((? 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 upstream release
+ (list (make-warning package
+ (G_ "updater '~a' failed to find \
+upstream releases")
+ (list (upstream-updater-name updater))
+ #:field 'source)))))))
(define (check-archival package)
((? 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-hash origin) ;XXX: for ungoogled-chromium
+ (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium
+ content-hash-value) ;& icecat
(let ((hash (origin-hash origin)))
(match (lookup-content (content-hash-value hash)
(symbol->string
'())))
'()))))
(match-lambda*
- ((key url method response)
+ (('swh-error url method response)
(response->warning url method response))
((key . args)
(if (eq? key skip-key)
'()
(apply throw key args))))))))
+(define (check-haskell-stackage package)
+ "Check whether PACKAGE is a Haskell package ahead of the current
+Stackage LTS version."
+ (match (with-networking-fail-safe
+ (format #f (G_ "while retrieving upstream info for '~a'")
+ (package-name package))
+ #f
+ (package-latest-release package (list %stackage-updater)))
+ ((? upstream-source? source)
+ (if (version>? (package-version package)
+ (upstream-source-version source))
+ (list
+ (make-warning package
+ (G_ "ahead of Stackage LTS version ~a")
+ (list (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '())))
+
\f
;;;
;;; Source code formatting.
"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))))
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (let ((line (- (location-line location) 1)))
+ (match (search-path %load-path (location-file location))
+ ((? string? file)
+ (report-formatting-issues package file line))
+ (#f
+ ;; It could be that LOCATION lists a "true" relative file
+ ;; name--i.e., not relative to an element of %LOAD-PATH.
+ (let ((file (location-file location)))
+ (if (file-exists? file)
+ (report-formatting-issues package file line)
+ (list (make-warning package
+ (G_ "source file not found"))))))))
'())))
\f
(define %local-checkers
(list
+ (lint-checker
+ (name 'name)
+ (description "Validate package names")
+ (check check-name))
(lint-checker
(name 'description)
(description "Validate package descriptions")
(name 'patch-file-names)
(description "Validate file names and availability of patches")
(check check-patch-file-names))
+ (lint-checker
+ (name 'patch-headers)
+ (description "Validate patch headers")
+ (check check-patch-headers))
(lint-checker
(name 'formatting)
(description "Look for formatting issues in the source")
(lint-checker
(name 'archival)
(description "Ensure source code archival on Software Heritage")
- (check check-archival))))
+ (check check-archival))
+ (lint-checker
+ (name 'haskell-stackage)
+ (description "Ensure Haskell packages use Stackage LTS versions")
+ (check check-haskell-stackage))))
(define %all-checkers
(append %local-checkers
HCoop / jackhill / guix / guix.git / blobdiff