WIP: Add package input loop detection.add-package-input-loop-detection

1 files changed, 50 insertions, 11 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 94e464cd01..383aa8d089 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1538,7 +1538,7 @@ Return the cached result when available."
          (#f
           (cache! cache package key thunk)))))))
 
-(define* (expand-input package input system #:key target)
+(define* (expand-input package input system #:key target seen-packages seen-package-list)
   "Expand INPUT, an input tuple, to a name/<gexp-input> tuple.  PACKAGE is
 only used to provide contextual information in exceptions."
   (with-monad %store-monad
@@ -1555,7 +1555,9 @@ only used to provide contextual information in exceptions."
                                                                target system
                                                                #:graft? #f)
                                     (package->derivation package system
-                                                         #:graft? #f))))
+                                                         #:graft? #f
+                                                         #:seen-packages seen-packages
+                                                         #:seen-package-list seen-package-list))))
          (return (list name (gexp-input drv #:native? (not target))))))
       (((? string? name) (? package? package) (? string? output))
        (mlet %store-monad ((drv (if target
@@ -1563,7 +1565,9 @@ only used to provide contextual information in exceptions."
                                                                target system
                                                                #:graft? #f)
                                     (package->derivation package system
-                                                         #:graft? #f))))
+                                                         #:graft? #f
+                                                         #:seen-packages seen-packages
+                                                         #:seen-package-list seen-package-list))))
          (return (list name (gexp-input drv output #:native? (not target))))))
 
       (((? string? name) (? file-like? thing))
@@ -1788,7 +1792,8 @@ TARGET."
                       (derivation=? obj1 obj2))
                  (equal? obj1 obj2))))))))
 
-(define* (bag->derivation bag #:optional context)
+(define* (bag->derivation bag #:optional context
+                          #:key seen-packages seen-package-list)
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
 a package object describing the context in which the call occurs, for improved
 error reporting."
@@ -1797,7 +1802,9 @@ error reporting."
       (mlet* %store-monad ((system ->  (bag-system bag))
                            (inputs ->  (bag-transitive-inputs bag))
                            (input-drvs (mapm %store-monad
-                                             (cut expand-input context <> system)
+                                             (cut expand-input context <> system
+                                                  #:seen-packages seen-packages
+                                                  #:seen-package-list seen-package-list)
                                              inputs))
                            (paths ->   (delete-duplicates
                                         (append-map (match-lambda
@@ -1815,7 +1822,8 @@ error reporting."
                #:outputs (bag-outputs bag) #:system system
                (bag-arguments bag)))))
 
-(define* (bag->cross-derivation bag #:optional context)
+(define* (bag->cross-derivation bag #:optional context
+                                #:key seen-packages seen-package-list)
   "Return the derivation to build BAG, which is actually a cross build.
 Optionally, CONTEXT can be a package object denoting the context of the call.
 This is an internal procedure."
@@ -1824,15 +1832,21 @@ This is an internal procedure."
                        (host ->     (bag-transitive-host-inputs bag))
                        (host-drvs   (mapm %store-monad
                                           (cut expand-input context <>
-                                               system #:target target)
+                                               system #:target target
+                                               #:seen-packages seen-packages
+                                               #:seen-package-list seen-package-list)
                                           host))
                        (target* ->  (bag-transitive-target-inputs bag))
                        (target-drvs (mapm %store-monad
-                                          (cut expand-input context <> system)
+                                          (cut expand-input context <> system
+                                               #:seen-packages seen-packages
+                                               #:seen-package-list seen-package-list)
                                           target*))
                        (build ->    (bag-transitive-build-inputs bag))
                        (build-drvs  (mapm %store-monad
-                                          (cut expand-input context <> system)
+                                          (cut expand-input context <> system
+                                               #:seen-packages seen-packages
+                                               #:seen-package-list seen-package-list)
                                           build))
                        (all ->      (append build target* host))
                        (paths ->    (delete-duplicates
@@ -1867,15 +1881,40 @@ This is an internal procedure."
 
 (define* (package->derivation package
                               #:optional (system (%current-system))
-                              #:key (graft? (%graft?)))
+                              #:key (graft? (%graft?))
+                              (seen-packages (setq))
+                              (seen-package-list '()))
   "Return the <derivation> object of PACKAGE for SYSTEM."
 
+  (if (set-contains? seen-packages package)
+      (begin
+        (simple-format #t "\nerror: input loop detected, error generating a derivation for ~A\n"
+                       (last seen-package-list))
+        (display "
+This shouldn't happen with Guix packages, please consider reporting a bug.\n")
+        (display "
+If any of the packages below are not included in Guix, it could be that one of
+them is causing the loop. The packages are listed in reverse order, so the
+first package listed is a input to the second package for example, and the
+start and end of the detected loop is highlighted with an arrow (--->).\n\n")
+        (for-each (lambda (seen-package)
+                    (if (eq? package seen-package)
+                        (display " --->"))
+                    (simple-format #t "\t~A\n" seen-package))
+                  (cons package
+                        seen-package-list))
+        (exit 1)))
+
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; system, will be queried many, many times in a row.
   (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
                                                       #:graft? graft?))
-                                (drv (bag->derivation bag package)))
+                                (drv (bag->derivation bag package
+                                                      #:seen-packages
+                                                      (set-insert package seen-packages)
+                                                      #:seen-package-list
+                                                      (cons package seen-package-list))))
              (if graft?
                  (>>= (bag-grafts bag)
                       (match-lambda