;;; 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>
+;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix memoization)
+ #:use-module (guix profiles)
+ #:use-module (guix monads)
#:use-module (guix scripts)
#:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
#:use-module (guix gnu-maintenance)
check-for-updates
check-formatting
check-archival
+ check-profile-collisions
lint-warning
lint-warning?
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"
"gobject-introspection"
"googletest-source"
"groff"
+ "gtk-doc"
"help2man"
"intltool"
"itstool"
"libtool"
+ "m4"
"qttools"
"yasm" "nasm" "fasm"
"python-coverage" "python2-coverage"
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx"
+ "scdoc"
"swig"
"qmake"
"qttools"
(or (and=> (package-source package) origin-patches)
'()))
+ (define (starts-with-package-name? file-name)
+ (and=> (string-contains file-name (package-name package))
+ zero?))
+
(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.
+ (starts-with-package-name? (basename patch)))
+ ((? origin? patch)
+ (starts-with-package-name? (origin-actual-file-name patch)))
+ (_ #f)) ;must be some other file-like object
patches)
'()
(list
;; 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)
(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-profile-collisions package #:key store)
+ "Check for collisions that would occur when installing PACKAGE as a result
+of the propagated inputs it pulls in."
+ (define (do-check store)
+ (guard (c ((profile-collision-error? c)
+ (let ((first (profile-collision-error-entry c))
+ (second (profile-collision-error-conflict c)))
+ (define format
+ (if (string=? (manifest-entry-version first)
+ (manifest-entry-version second))
+ manifest-entry-item
+ (lambda (entry)
+ (string-append (manifest-entry-name entry) "@"
+ (manifest-entry-version entry)))))
+
+ (list (make-warning package
+ (G_ "propagated inputs ~a and ~a collide")
+ (list (format first)
+ (format second)))))))
+ ;; Disable grafts to avoid building PACKAGE and its dependencies.
+ (parameterize ((%graft? #f))
+ (run-with-store store
+ (mbegin %store-monad
+ (check-for-collisions (packages->manifest (list package))
+ (%current-system))
+ (return '()))))))
+
+ (if store
+ (do-check store)
+ (with-store store
+ (do-check store))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
(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)
(()
((? 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 \
+ (if (origin-hash origin) ;XXX: for ungoogled-chromium
+ (let ((hash (origin-hash origin)))
+ (match (lookup-content (content-hash-value hash)
+ (symbol->string
+ (content-hash-algorithm hash)))
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
Heritage")
- #:field 'source)))
- ((? content?)
- '()))
+ #:field 'source)))
+ ((? content?)
+ '())))
'()))))
(match-lambda*
- ((key url method response)
+ (('swh-error url method response)
(response->warning url method response))
((key . args)
(if (eq? key skip-key)
(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 'profile-collisions)
+ (description "Report collisions that would occur due to propagated inputs")
+ (check check-profile-collisions)
+ (requires-store? #t))
(lint-checker
(name 'patch-file-names)
(description "Validate file names and availability of patches")
HCoop / jackhill / guix / guix.git / blobdiff