From 100aed7c924bb107ff3c836334bcdf1b1f9c746a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Feb 2018 16:28:42 +0000 Subject: WIP: Add package input loop detection. --- guix/packages.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++---------- 1 file 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/ 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 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 -- cgit v1.2.3