aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2018-02-05 16:28:42 +0000
committerChristopher Baines <mail@cbaines.net>2022-10-04 14:15:17 +0100
commit100aed7c924bb107ff3c836334bcdf1b1f9c746a (patch)
tree826923290ab73b9b0c435949a0c6ff4e4601321f
parentba84c8c4489e0b22fc692724416829c377b4ee91 (diff)
downloadguix-add-package-input-loop-detection.tar
guix-add-package-input-loop-detection.tar.gz
WIP: Add package input loop detection.add-package-input-loop-detection
-rw-r--r--guix/packages.scm61
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