diff options
Diffstat (limited to 'guix/lint.scm')
| -rw-r--r-- | guix/lint.scm | 72 |
1 files changed, 60 insertions, 12 deletions
diff --git a/guix/lint.scm b/guix/lint.scm index e192f292a4..fa507546f5 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2017 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,8 @@ #: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) @@ -83,6 +86,7 @@ check-for-updates check-formatting check-archival + check-profile-collisions lint-warning lint-warning? @@ -669,13 +673,17 @@ patch could not be found." (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 @@ -965,6 +973,38 @@ descriptions maintained upstream." (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." (match (package-license package) @@ -1154,15 +1194,18 @@ try again later") ((? 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) @@ -1342,6 +1385,11 @@ or a list thereof") (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") (check check-patch-file-names)) |