From ac8434025cc16fee2bc84345313305fc9146ca20 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Feb 2018 16:28:42 +0000 Subject: [PATCH] WIP: Add package input loop detection. --- guix/packages.scm | 60 +++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 50 insertions(+), 10 deletions(-) diff --git a/guix/packages.scm b/guix/packages.scm index 7d884aa36..c34191183 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -21,6 +21,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix packages) + #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix records) #:use-module (guix store) @@ -860,7 +861,8 @@ Return the cached result when available." ((_ package system body ...) (cached (=> %derivation-cache) package system body ...)))) -(define* (expand-input store package input system #:optional cross-system) +(define* (expand-input store package input system #:optional cross-system + #:key seen-packages seen-package-list) "Expand INPUT, an input tuple, such that it contains only references to derivation paths or store paths. PACKAGE is only used to provide contextual information in exceptions." @@ -873,7 +875,9 @@ information in exceptions." (if cross-system (cut package-cross-derivation store <> cross-system system #:graft? #f) - (cut package-derivation store <> system #:graft? #f))) + (cut package-derivation store <> system #:graft? #f + #:seen-packages seen-packages + #:seen-package-list seen-package-list))) (match input (((? string? name) (? package? package)) @@ -1077,7 +1081,8 @@ TARGET." (bag-grafts store bag))) (define* (bag->derivation store bag - #:optional context) + #: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." @@ -1085,7 +1090,9 @@ error reporting." (bag->cross-derivation store bag) (let* ((system (bag-system bag)) (inputs (bag-transitive-inputs bag)) - (input-drvs (map (cut expand-input store context <> system) + (input-drvs (map (cut expand-input store context <> system + #:seen-packages seen-packages + #:seen-package-list seen-package-list) inputs)) (paths (delete-duplicates (append-map (match-lambda @@ -1102,20 +1109,27 @@ error reporting." (bag-arguments bag))))) (define* (bag->cross-derivation store bag - #:optional context) + #: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." (let* ((system (bag-system bag)) (target (bag-target bag)) (host (bag-transitive-host-inputs bag)) - (host-drvs (map (cut expand-input store context <> system target) + (host-drvs (map (cut expand-input store context <> system target + #:seen-packages seen-packages + #:seen-package-list seen-package-list) host)) (target* (bag-transitive-target-inputs bag)) - (target-drvs (map (cut expand-input store context <> system) + (target-drvs (map (cut expand-input store context <> system + #:seen-packages seen-packages + #:seen-package-list seen-package-list) target*)) (build (bag-transitive-build-inputs bag)) - (build-drvs (map (cut expand-input store context <> system) + (build-drvs (map (cut expand-input store context <> system + #:seen-packages seen-packages + #:seen-package-list seen-package-list) build)) (all (append build target* host)) (paths (delete-duplicates @@ -1144,15 +1158,41 @@ This is an internal procedure." (define* (package-derivation store 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") + (show-bug-report-information) + (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. (cached package (cons system graft?) (let* ((bag (package->bag package system #f #:graft? graft?)) - (drv (bag->derivation store bag package))) + (drv (bag->derivation store bag package + #:seen-packages + (set-insert package seen-packages) + #:seen-package-list + (cons package seen-package-list)))) (if graft? (match (bag-grafts store bag) (() -- 2.16.1