Merge branch 'master' into core-updates

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))