From 465a0d65ae371cd6ae85a5f4f356c8989a863e9f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 15:17:10 +0100 Subject: guix package: Avoid 'find-newest-available-packages'. * guix/scripts/package.scm (transaction-upgrade-entry): Use 'find-best-packages-by-name' instead of 'find-newest-available-packages'. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades") ("transaction-upgrade-entry, one upgrade") ("transaction-upgrade-entry, superseded package"): Adjust accordingly. --- tests/packages.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'tests/packages.scm') diff --git a/tests/packages.scm b/tests/packages.scm index 237feb7aba..eb8ede3207 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,8 +96,8 @@ (test-assert "transaction-upgrade-entry, zero upgrades" (let* ((old (dummy-package "foo" (version "1"))) - (tx (mock ((gnu packages) find-newest-available-packages - (const vlist-null)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const '())) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) @@ -109,8 +109,8 @@ (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) - (tx (mock ((gnu packages) find-newest-available-packages - (const (vhash-cons "foo" (list "2" new) vlist-null))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list new))) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) @@ -126,8 +126,8 @@ (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "bar" (version "2"))) (dep (deprecated-package "foo" new)) - (tx (mock ((gnu packages) find-newest-available-packages - (const (vhash-cons "foo" (list "2" dep) vlist-null))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list dep))) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) -- cgit 1.4.1 From 5fbdc9a5aa63fd51c65d30fe3d30608d01fe1bc8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 17:23:39 +0100 Subject: channels: Compute a package cache and use it. * gnu/packages.scm (cache-is-authoritative?, load-package-cache) (cache-lookup, generate-package-cache): New procedures. (%package-cache-file): New variable. (find-packages-by-name): Rename to... (find-packages-by-name/direct): ... this. (find-packages-by-name): Rewrite to use the package cache when 'cache-is-authoritative?' returns true. * tests/packages.scm ("find-packages-by-name + version, with cache") ("find-packages-by-name with cache"): New tests. * guix/channels.scm (package-cache-file): New procedure. (%channel-profile-hooks): New variable. (channel-instances->derivation): Use it in #:hooks. * guix/scripts/package.scm (build-and-use-profile): Add #:hooks and honor it. * guix/scripts/pull.scm (build-and-install): Pass #:hooks to UPDATE-PROFILE. --- gnu/packages.scm | 127 +++++++++++++++++++++++++++++++++++++++++++++-- guix/channels.scm | 36 +++++++++++++- guix/scripts/package.scm | 8 +-- guix/scripts/pull.scm | 1 + tests/packages.scm | 18 +++++++ 5 files changed, 181 insertions(+), 9 deletions(-) (limited to 'tests/packages.scm') diff --git a/gnu/packages.scm b/gnu/packages.scm index 4a85cf4b87..6796db80a4 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -28,11 +28,14 @@ #:use-module (guix memoization) #:use-module ((guix build utils) #:select ((package-name->name+version - . hyphen-separated-name->name+version))) + . hyphen-separated-name->name+version) + mkdir-p)) #:autoload (guix profiles) (packages->manifest) #:use-module (guix describe) #:use-module (ice-9 vlist) #:use-module (ice-9 match) + #:autoload (ice-9 binary-ports) (put-bytevector) + #:autoload (system base compile) (compile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -56,7 +59,9 @@ specification->package specification->package+output - specifications->manifest)) + specifications->manifest + + generate-package-cache)) ;;; Commentary: ;;; @@ -135,6 +140,14 @@ for system '~a'") ;; Default search path for package modules. `((,%distro-root-directory . "gnu/packages"))) +(define (cache-is-authoritative?) + "Return true if the pre-computed package cache is authoritative. It is not +authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L' +flags." + (equal? (%package-module-path) + (append %default-package-module-path + (package-path-entries)))) + (define %package-module-path ;; Search path for package modules. Each item must be either a directory ;; name or a pair whose car is a directory and whose cdr is a sub-directory @@ -183,7 +196,35 @@ is guaranteed to never traverse the same package twice." init modules)) -(define find-packages-by-name +(define %package-cache-file + ;; Location of the package cache. + "/lib/guix/package.cache") + +(define load-package-cache + (mlambda (profile) + "Attempt to load the package cache. On success return a vhash keyed by +package names. Return #f on failure." + (match profile + (#f #f) + (profile + (catch 'system-error + (lambda () + (define lst + (load-compiled (string-append profile %package-cache-file))) + (fold (lambda (item vhash) + (match item + (#(name version module symbol outputs + supported? deprecated? + file line column) + (vhash-cons name item vhash)))) + vlist-null + lst)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args)))))))) + +(define find-packages-by-name/direct ;bypass the cache (let ((packages (delay (fold-packages (lambda (p r) (vhash-cons (package-name p) p r)) @@ -202,6 +243,37 @@ decreasing version order." matching) matching))))) +(define (cache-lookup cache name) + "Lookup package NAME in CACHE. Return a list sorted in increasing version +order." + (define (package-version? (vector-ref v2 1) (vector-ref v1 1))) + + (sort (vhash-fold* cons '() name cache) + package-versionbool (member (%current-system) + (package-supported-systems package))) + ,(->bool (package-superseded package)) + ,@(let ((loc (package-location package))) + (if loc + `(,(location-file loc) + ,(location-line loc) + ,(location-column loc)) + '(#f #f #f)))) + result))) + (_ + result))) + + (define exp + (fold-module-public-variables* expand-cache '() + (all-modules (%package-module-path) + #:warn + warn-about-load-error))) + + (mkdir-p (dirname cache-file)) + (call-with-output-file cache-file + (lambda (port) + ;; Store the cache as a '.go' file. This makes loading fast and reduces + ;; heap usage since some of the static data is directly mmapped. + (put-bytevector port + (compile `'(,@exp) + #:to 'bytecode + #:opts '(#:to-file? #t))))) + cache-file) + (define %sigint-prompt ;; The prompt to jump to upon SIGINT. diff --git a/guix/channels.scm b/guix/channels.scm index 6b860f3bd8..cd8a0131bd 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -21,6 +21,7 @@ #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) @@ -31,7 +32,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - #:autoload (guix self) (whole-package) + #:autoload (guix self) (whole-package make-config.scm) + #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) #:export (channel channel? @@ -52,6 +54,7 @@ checkout->channel-instance latest-channel-derivation channel-instances->manifest + %channel-profile-hooks channel-instances->derivation)) ;;; Commentary: @@ -416,11 +419,40 @@ channel instances." (zip instances derivations)))) (return (manifest entries)))) +(define (package-cache-file manifest) + "Build a package cache file for the instance in MANIFEST. This is meant to +be used as a profile hook." + (mlet %store-monad ((profile (profile-derivation manifest + #:hooks '()))) + + (define build + #~(begin + (use-modules (gnu packages)) + + (if (defined? 'generate-package-cache) + (begin + ;; Delegate package cache generation to the inferior. + (format (current-error-port) + "Generating package cache for '~a'...~%" + #$profile) + (generate-package-cache #$output)) + (mkdir #$output)))) + + (gexp->derivation-in-inferior "guix-package-cache" build + profile + #:properties '((type . profile-hook) + (hook . package-cache))))) + +(define %channel-profile-hooks + ;; The default channel profile hooks. + (cons package-cache-file %default-profile-hooks)) + (define (channel-instances->derivation instances) "Return the derivation of the profile containing INSTANCES, a list of channel instances." (mlet %store-monad ((manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (profile-derivation manifest + #:hooks %channel-profile-hooks))) (define latest-channel-instances* (store-lift latest-channel-instances)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba33790eda..e9bed0be1e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + (hooks %default-profile-hooks) allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, -do not treat collisions in MANIFEST as an error." +do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile +hooks\" run when building the profile." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? - #:hooks (if bootstrap? - '() - %default-profile-hooks) + #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0339b149fa..513434c5f1 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -188,6 +188,7 @@ true, display what would be built without actually building it." (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest + #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? (return (display-profile-news profile)))))) diff --git a/tests/packages.scm b/tests/packages.scm index eb8ede3207..2720ba5a15 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1005,6 +1005,24 @@ (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) +(test-equal "find-packages-by-name with cache" + (find-packages-by-name "guile") + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-packages-by-name "guile")))))) + +(test-equal "find-packages-by-name + version, with cache" + (find-packages-by-name "guile" "2") + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-packages-by-name "guile" "2")))))) + (test-assert "--search-paths with pattern" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables when file patterns are used (in particular, it must follow -- cgit 1.4.1 From ee8099f5b688ce5f57790db4122f0b5b91a26216 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Jan 2019 14:27:10 +0100 Subject: edit: Use 'specification->location' to read information from the cache. That way 'guix edit' doesn't need to load any package module. * gnu/packages.scm (find-package-locations, specification->location): New procedures. * guix/scripts/edit.scm (package->location-specification): Rename to... (location->location-specification): ... this. Expect a location object instead of a package. (guix-edit): Use 'specification->location' instead of 'specification->package'. * tests/packages.scm ("find-package-locations") ("find-package-locations with cache") ("specification->location"): New tests. --- gnu/packages.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/edit.scm | 29 +++++++++++------------------ tests/packages.scm | 23 +++++++++++++++++++++++ 3 files changed, 85 insertions(+), 18 deletions(-) (limited to 'tests/packages.scm') diff --git a/gnu/packages.scm b/gnu/packages.scm index 6796db80a4..cf655e7448 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -55,10 +55,12 @@ fold-packages find-packages-by-name + find-package-locations find-best-packages-by-name specification->package specification->package+output + specification->location specifications->manifest generate-package-cache)) @@ -274,6 +276,31 @@ decreasing version order." versions modules symbols))) (find-packages-by-name/direct name version))) +(define* (find-package-locations name #:optional version) + "Return a list of version/location pairs corresponding to each package +matching NAME and VERSION." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (match (cache-lookup cache name) + (#f '()) + ((#(name versions modules symbols outputs + supported? deprecated? + files lines columns) ...) + (fold (lambda (version* file line column result) + (if (and file + (or (not version) + (version-prefix? version version*))) + (alist-cons version* (location file line column) + result) + result)) + '() + versions files lines columns))) + (map (lambda (package) + (cons (package-version package) (package-location package))) + (find-packages-by-name/direct name version)))) + (define (find-best-packages-by-name name version) "If version is #f, return the list of packages named NAME with the highest version numbers; otherwise, return the list of packages named NAME and at @@ -393,6 +420,30 @@ present, return the preferred newest version." (let-values (((name version) (package-name->name+version spec))) (%find-package spec name version))) +(define (specification->location spec) + "Return the location of the highest-numbered package matching SPEC, a +specification such as \"guile@2\" or \"emacs\"." + (let-values (((name version) (package-name->name+version spec))) + (match (find-package-locations name version) + (() + (if version + (leave (G_ "~A: package not found for version ~a~%") name version) + (leave (G_ "~A: unknown package~%") name))) + (lst + (let* ((highest (match lst (((version . _) _ ...) version))) + (locations (take-while (match-lambda + ((version . location) + (string=? version highest))) + lst))) + (match locations + (((version . location) . rest) + (unless (null? rest) + (warning (G_ "ambiguous package specification `~a'~%") spec) + (warning (G_ "choosing ~a@~a from ~a~%") + name version + (location->string location))) + location))))))) + (define* (specification->package+output spec #:optional (output "out")) "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ line." '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/tests/packages.scm b/tests/packages.scm index 2720ba5a15..8aa117a2e7 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1131,6 +1131,29 @@ (lambda (key . args) key))) +(test-equal "find-package-locations" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (find-package-locations "guile")) + +(test-equal "find-package-locations with cache" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-package-locations "guile")))))) + +(test-equal "specification->location" + (package-location (specification->package "guile@2")) + (specification->location "guile@2")) + (test-end "packages") ;;; Local Variables: -- cgit 1.4.1 From 0ea939fb796fdd4f0d46d3534b2ec6135e0f3dc7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Jan 2019 15:36:49 +0100 Subject: guix package: '--list-available' can use data from the cache. * gnu/packages.scm (fold-available-packages): New procedure. * guix/scripts/package.scm (process-query): Use it instead of 'fold-packages'. * tests/packages.scm ("fold-available-packages with/without cache"): New test. --- gnu/packages.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 45 +++++++++++++++++++++++++-------------------- tests/packages.scm | 22 ++++++++++++++++++++++ 3 files changed, 92 insertions(+), 20 deletions(-) (limited to 'tests/packages.scm') diff --git a/gnu/packages.scm b/gnu/packages.scm index cf655e7448..a1814205f9 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -53,6 +53,7 @@ %default-package-module-path fold-packages + fold-available-packages find-packages-by-name find-package-locations @@ -182,6 +183,50 @@ flags." directory)) %load-path))) +(define (fold-available-packages proc init) + "Fold PROC over the list of available packages. For each available package, +PROC is called along these lines: + + (PROC NAME VERSION RESULT + #:outputs OUTPUTS + #:location LOCATION + …) + +PROC can use #:allow-other-keys to ignore the bits it's not interested in. +When a package cache is available, this procedure does not actually load any +package module." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (vhash-fold (lambda (name vector result) + (match vector + (#(name version module symbol outputs + supported? deprecated? + file line column) + (proc name version result + #:outputs outputs + #:location (and file + (location file line column)) + #:supported? supported? + #:deprecated? deprecated?)))) + init + cache) + (fold-packages (lambda (package result) + (proc (package-name package) + (package-version package) + result + #:outputs (package-outputs package) + #:location (package-location package) + #:supported? + (->bool + (member (%current-system) + (package-supported-systems package))) + #:deprecated? + (->bool + (package-superseded package)))) + init))) + (define* (fold-packages proc init #:optional (modules (all-modules (%package-module-path) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e9bed0be1e..a633d2ee6d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -736,29 +736,34 @@ processed, #f otherwise." (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? superseded? + #:allow-other-keys) + (if (and supported? (not superseded?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string))) #t) -- cgit 1.4.1 From f9e8a12379c6fefc9e5c3c7fc3926599bbefc013 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Jan 2019 17:41:11 +0100 Subject: store: Rename '&nix-error' to '&store-error'. * guix/store.scm (&nix-error): Rename to... (&store-error): ... this, and adjust users. (&nix-connection-error): Rename to... (&store-connection-error): ... this, and adjust users. (&nix-protocol-error): Rename to... (&store-protocol-error): ... this, adjust users. (&nix-error, &nix-connection-error, &nix-protocol-error): Define these condition types and their getters as deprecrated aliases. * build-aux/run-system-tests.scm, guix/derivations.scm, guix/grafts.scm, guix/scripts/challenge.scm, guix/scripts/graph.scm, guix/scripts/lint.scm, guix/scripts/offload.scm, guix/serialization.scm, guix/ssh.scm, guix/tests.scm, guix/ui.scm, tests/derivations.scm, tests/gexp.scm, tests/guix-daemon.sh, tests/packages.scm, tests/store.scm, doc/guix.texi: Adjust to use the new names. --- build-aux/run-system-tests.scm | 2 +- doc/guix.texi | 2 +- guix/derivations.scm | 2 +- guix/grafts.scm | 2 +- guix/scripts/challenge.scm | 2 +- guix/scripts/graph.scm | 2 +- guix/scripts/lint.scm | 4 +-- guix/scripts/offload.scm | 6 ++-- guix/serialization.scm | 2 +- guix/ssh.scm | 6 ++-- guix/store.scm | 77 ++++++++++++++++++++++++++++-------------- guix/tests.scm | 2 +- guix/ui.scm | 10 +++--- tests/derivations.scm | 42 +++++++++++------------ tests/gexp.scm | 4 +-- tests/guix-daemon.sh | 8 ++--- tests/packages.scm | 2 +- tests/store.scm | 46 ++++++++++++------------- 18 files changed, 123 insertions(+), 98 deletions(-) (limited to 'tests/packages.scm') diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm index bcd7547704..fd1f6653af 100644 --- a/build-aux/run-system-tests.scm +++ b/build-aux/run-system-tests.scm @@ -30,7 +30,7 @@ (define (built-derivations* drv) (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (values (build-derivations store drv) store)))) diff --git a/doc/guix.texi b/doc/guix.texi index 245a18bc70..e70fed2f1c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5027,7 +5027,7 @@ Return @code{#t} when @var{path} designates a valid store item and invalid, for instance because it is the result of an aborted or failed build.) -A @code{&nix-protocol-error} condition is raised if @var{path} is not +A @code{&store-protocol-error} condition is raised if @var{path} is not prefixed by the store directory (@file{/gnu/store}). @end deffn diff --git a/guix/derivations.scm b/guix/derivations.scm index f6176a78fd..fb2fa177be 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -113,7 +113,7 @@ ;;; Error conditions. ;;; -(define-condition-type &derivation-error &nix-error +(define-condition-type &derivation-error &store-error derivation-error? (derivation derivation-error-derivation)) diff --git a/guix/grafts.scm b/guix/grafts.scm index db9c6854fd..a3e12f6efd 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -189,7 +189,7 @@ available." items))) (define (references* items) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; As a last resort, build DRV and query the references of the ;; build result. diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f0693ed8df..65de42053d 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -109,7 +109,7 @@ "Return the hash of ITEM, a store item, if ITEM was built locally. Otherwise return #f." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (if (locally-built? store item) (values (query-path-hash store item) store) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 145a574dba..8efeef3274 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -299,7 +299,7 @@ this type of graph"))))))) information available in the local store or using information about substitutes." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) (values (substitutable-references info) store)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 665adcfb8d..ddad5b7fd0 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -833,11 +833,11 @@ descriptions maintained upstream." (define (try system) (catch #t (lambda () - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") system - (nix-protocol-error-message c)))) + (store-protocol-error-message c)))) ((message-condition? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 30fe69ad6d..2116b38425 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -358,12 +358,12 @@ MACHINE." (format (current-error-port) "@ build-remote ~a ~a~%" (derivation-file-name drv) (build-machine-name machine)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (format (current-error-port) (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) - (nix-protocol-error-message c)) + (store-protocol-error-message c)) (let* ((inferior (false-if-exception (remote-inferior session))) (space (false-if-exception (node-free-disk-space inferior)))) diff --git a/guix/serialization.scm b/guix/serialization.scm index 7c0fea552d..e14b7d1b9f 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -59,7 +59,7 @@ ;; Similar to serialize.cc in Nix. -(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? +(define-condition-type &nar-error &error ; XXX: inherit from &store-error ? nar-error? (file nar-error-file) ; file we were restoring, or #f (port nar-error-port)) ; port from which we read diff --git a/guix/ssh.scm b/guix/ssh.scm index 77329618d5..2b286a67b2 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -328,17 +328,17 @@ Return the list of store items actually sent." missing) (('protocol-error message) (raise (condition - (&nix-protocol-error (message message) (status 42))))) + (&store-protocol-error (message message) (status 42))))) (('error key args ...) (raise (condition - (&nix-protocol-error + (&store-protocol-error (message (call-with-output-string (lambda (port) (print-exception port #f key args)))) (status 43))))) (_ (raise (condition - (&nix-protocol-error + (&store-protocol-error (message "unknown error while sending files over SSH") (status 44))))))))) diff --git a/guix/store.scm b/guix/store.scm index f8c79788b8..d079147529 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -68,6 +68,15 @@ current-store-protocol-version ;for internal use mcached + &store-error store-error? + &store-connection-error store-connection-error? + store-connection-error-file + store-connection-error-code + &store-protocol-error store-protocol-error? + store-protocol-error-message + store-protocol-error-status + + ;; Deprecated forms for '&store-error' et al. &nix-error nix-error? &nix-connection-error nix-connection-error? nix-connection-error-file @@ -377,34 +386,50 @@ (define-deprecated/alias nix-server-socket store-connection-socket) -(define-condition-type &nix-error &error - nix-error?) +(define-condition-type &store-error &error + store-error?) -(define-condition-type &nix-connection-error &nix-error - nix-connection-error? - (file nix-connection-error-file) - (errno nix-connection-error-code)) +(define-condition-type &store-connection-error &store-error + store-connection-error? + (file store-connection-error-file) + (errno store-connection-error-code)) + +(define-condition-type &store-protocol-error &store-error + store-protocol-error? + (message store-protocol-error-message) + (status store-protocol-error-status)) + +(define-deprecated/alias &nix-error &store-error) +(define-deprecated/alias nix-error? store-error?) +(define-deprecated/alias &nix-connection-error &store-connection-error) +(define-deprecated/alias nix-connection-error? store-connection-error?) +(define-deprecated/alias nix-connection-error-file + store-connection-error-file) +(define-deprecated/alias nix-connection-error-code + store-connection-error-code) +(define-deprecated/alias &nix-protocol-error &store-protocol-error) +(define-deprecated/alias nix-protocol-error? store-protocol-error?) +(define-deprecated/alias nix-protocol-error-message + store-protocol-error-message) +(define-deprecated/alias nix-protocol-error-status + store-protocol-error-status) -(define-condition-type &nix-protocol-error &nix-error - nix-protocol-error? - (message nix-protocol-error-message) - (status nix-protocol-error-status)) (define-syntax-rule (system-error-to-connection-error file exp ...) "Catch 'system-error' exceptions and translate them to -'&nix-connection-error'." +'&store-connection-error'." (catch 'system-error (lambda () exp ...) (lambda args (let ((errno (system-error-errno args))) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file file) (errno errno)))))))) (define (open-unix-domain-socket file) "Connect to the Unix-domain socket at FILE and return it. Raise a -'&nix-connection-error' upon error." +'&store-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) @@ -420,7 +445,7 @@ (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a -'&nix-connection-error' upon error." +'&store-connection-error' upon error." (let ((sock (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0)))) @@ -452,7 +477,7 @@ ;; Connection failed, so try one of the other addresses. (close s) (if (null? rest) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file host) (errno (system-error-errno args))))) (loop rest)))))))))) @@ -461,7 +486,7 @@ "Connect to the daemon at URI, a string that may be an actual URI or a file name." (define (not-supported) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file uri) (errno ENOTSUP))))) @@ -510,8 +535,8 @@ for this connection will be pinned. Return a server object." ;; One of the 'write-' or 'read-' calls below failed, but this is ;; really a connection error. (raise (condition - (&nix-connection-error (file (or port uri)) - (errno EPROTO)) + (&store-connection-error (file (or port uri)) + (errno EPROTO)) (&message (message "build daemon handshake failed")))))) (let*-values (((port) (or port (connect-to-daemon uri))) @@ -689,14 +714,14 @@ encoding conversion errors." (not (eof-object? (lookahead-u8 p)))) (read-int p) 1))) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message error) (status status)))))) ((= k %stderr-last) ;; The daemon is done (see `stopWork' in `nix-worker.cc'.) #t) (else - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "invalid error code") (status k)))))))) @@ -926,7 +951,7 @@ bytevector) as its internal buffer, and a thunk to flush this output port." invalid item may exist on disk but still be invalid, for instance because it is the result of an aborted or failed build.) -A '&nix-protocol-error' condition is raised if PATH is not prefixed by the +A '&store-protocol-error' condition is raised if PATH is not prefixed by the store directory (/gnu/store)." boolean) @@ -1141,7 +1166,7 @@ Return #t on success." (build store things mode) (if (= mode (build-mode normal)) (build/old store things) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "unsupported build mode") (status 1)))))))))) @@ -1201,12 +1226,12 @@ error if there is no such root." (define (references/substitutes store items) "Return the list of list of references of ITEMS; the result has the same length as ITEMS. Query substitute information for any item missing from the -store at once. Raise a '&nix-protocol-error' exception if reference +store at once. Raise a '&store-protocol-error' exception if reference information for one of ITEMS is missing." (let* ((requested items) (local-refs (map (lambda (item) (or (hash-ref %reference-cache item) - (guard (c ((nix-protocol-error? c) #f)) + (guard (c ((store-protocol-error? c) #f)) (references store item)))) items)) (missing (fold-right (lambda (item local-ref result) @@ -1222,7 +1247,7 @@ information for one of ITEMS is missing." '() (substitutable-path-info store missing)))) (when (< (length substs) (length missing)) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "cannot determine \ the list of references") (status 1))))) @@ -1673,7 +1698,7 @@ where FILE is the entry's absolute file name and STAT is the result of "Monadic version of 'query-path-info' that returns #f when ITEM is not in the store." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; ITEM is not in the store; return #f. (values #f store))) (values (query-path-info store item) store)))) diff --git a/guix/tests.scm b/guix/tests.scm index f4948148c4..16a426c4f9 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -64,7 +64,7 @@ (define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri))) "Open a connection to the build daemon for tests purposes and return it." - (guard (c ((nix-error? c) + (guard (c ((store-error? c) (format (current-error-port) "warning: build daemon error: ~s~%" c) #f)) diff --git a/guix/ui.scm b/guix/ui.scm index 1e089753e1..9ff56ea85c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -684,14 +684,14 @@ or remove one of them from the profile.") file (or (port-filename* port) port)) (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) - ((nix-connection-error? c) + ((store-connection-error? c) (leave (G_ "failed to connect to `~a': ~a~%") - (nix-connection-error-file c) - (strerror (nix-connection-error-code c)))) - ((nix-protocol-error? c) + (store-connection-error-file c) + (strerror (store-connection-error-code c)))) + ((store-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. (leave (G_ "build failed: ~a~%") - (nix-protocol-error-message c))) + (store-protocol-error-message c))) ((derivation-missing-output-error? c) (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") (derivation-missing-output c) diff --git a/tests/derivations.scm b/tests/derivations.scm index 5f294c1827..c0601c0e88 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,9 +185,9 @@ (set-build-options %store #:use-substitutes? #f #:keep-going? #t) - (guard (c ((nix-protocol-error? c) - (and (= 100 (nix-protocol-error-status c)) - (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (= 100 (store-protocol-error-status c)) + (string-contains (store-protocol-error-message c) (derivation-file-name d1)) (not (valid-path? %store (derivation->output-path d1))) (valid-path? %store (derivation->output-path d2))))) @@ -222,8 +222,8 @@ (test-assert "unknown built-in builder" (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '()))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f))) @@ -253,8 +253,8 @@ . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (random-bytevector 100))))) ;wrong - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f)))) @@ -268,8 +268,8 @@ . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (random-bytevector 100))))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message (pk c)) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message (pk c)) "failed"))) (build-derivations %store (list drv)) #f)))) @@ -279,8 +279,8 @@ (drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" . ,(object->string url)))))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f))) @@ -607,7 +607,7 @@ `("-c" ,(string-append "echo " txt "> $out")) #:inputs `((,%bash) (,txt)) #:allowed-references '()))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -625,7 +625,7 @@ `("-c" ,"echo $out > $out") #:inputs `((,%bash)) #:allowed-references '()))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -644,7 +644,7 @@ `("-c" ,(string-append "echo " txt "> $out")) #:inputs `((,%bash) (,txt)) #:disallowed-references (list txt)))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -765,8 +765,8 @@ (builder '(begin (sleep 100) (mkdir %output) #t)) (drv (build-expression->derivation store "silent" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) - (and (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (string-contains (store-protocol-error-message c) "failed") (not (valid-path? store out-path))))) (build-derivations store (list drv)) @@ -779,8 +779,8 @@ (builder '(begin (sleep 100) (mkdir %output) #t)) (drv (build-expression->derivation store "slow" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) - (and (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (string-contains (store-protocol-error-message c) "failed") (not (valid-path? store out-path))))) (build-derivations store (list drv)) @@ -942,11 +942,11 @@ #f)) ; fail! (drv (build-expression->derivation %store "fail" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; Note that the output path may exist at this point, but it ;; is invalid. (and (string-match "build .* failed" - (nix-protocol-error-message c)) + (store-protocol-error-message c)) (not (valid-path? %store out-path))))) (build-derivations %store (list drv)) #f))) diff --git a/tests/gexp.scm b/tests/gexp.scm index c4b437cd49..cee2c96610 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -919,7 +919,7 @@ (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:allowed-references '())))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) @@ -943,7 +943,7 @@ (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:disallowed-references (list %bootstrap-guile))))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 9ae6e0b77a..4c19a55722 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2012, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -109,7 +109,7 @@ guile -c " (define (build-without-failing drv) (lambda (store) - (guard (c ((nix-protocol-error? c) (values #t store))) + (guard (c ((store-protocol-error? c) (values #t store))) (build-derivations store (list drv)) (values #f store)))) @@ -177,9 +177,9 @@ client_code=' `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text)))))) - (exit (guard (c ((nix-protocol-error? c) + (exit (guard (c ((store-protocol-error? c) (->bool - (string-contains (pk (nix-protocol-error-message c)) + (string-contains (pk (store-protocol-error-message c)) "failed")))) (build-derivations store (list drv)) #f))))' diff --git a/tests/packages.scm b/tests/packages.scm index ed635d9011..29e5e4103c 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -570,7 +570,7 @@ (symlink %output (string-append %output "/self")) #t))))) (d (package-derivation %store p))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)) #f))) diff --git a/tests/store.scm b/tests/store.scm index 5ff9308d7d..e28c0c5aaa 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -63,9 +63,9 @@ (test-equal "connection handshake error" EPROTO (let ((port (%make-void-port "rw"))) - (guard (c ((nix-connection-error? c) - (and (eq? port (nix-connection-error-file c)) - (nix-connection-error-code c)))) + (guard (c ((store-connection-error? c) + (and (eq? port (store-connection-error-file c)) + (store-connection-error-code c)))) (open-connection #f #:port port) 'broken))) @@ -120,7 +120,7 @@ (test-assert "valid-path? error" (with-store s - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (valid-path? s "foo") #f))) @@ -133,7 +133,7 @@ (with-store s (let-syntax ((true-if-error (syntax-rules () ((_ exp) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) exp #f))))) (and (true-if-error (valid-path? s "foo")) (true-if-error (valid-path? s "bar")) @@ -274,7 +274,7 @@ (test-assert "references/substitutes missing reference info" (with-store s (set-build-options s #:use-substitutes? #f) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (let* ((b (add-to-store s "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) @@ -422,7 +422,7 @@ %store "foo" `(display ,s) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system))))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "Here’s a Greek letter: λ.")) @@ -442,7 +442,7 @@ (display "lambda: λ\n")) #:guile-for-build (package-derivation %store %bootstrap-guile)))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "garbage: �lambda: λ")) @@ -620,12 +620,12 @@ #:fallback? #f #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; XXX: the daemon writes "hash mismatch in downloaded ;; path", but the actual error returned to the client ;; doesn't mention that. (pk 'corrupt c) - (not (zero? (nix-protocol-error-status c))))) + (not (zero? (store-protocol-error-status c))))) (build-derivations s (list d)) #f)))))) @@ -646,7 +646,7 @@ (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; The substituter failed as expected. Now make ;; sure that #:fallback? #t works correctly. (set-build-options s @@ -712,9 +712,9 @@ (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <>)))) (delete-paths %store (list file0 file1 file2)) - (guard (c ((nix-protocol-error? c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "not valid")))) ;; Here we get an exception because DUMP does not include FILE0 and ;; FILE1, which are dependencies of FILE2. @@ -816,10 +816,10 @@ (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'c c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "corrupt")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) @@ -906,10 +906,10 @@ (begin (write (random-text) entropy-port) (force-output entropy-port) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'determinism-exception c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result. Since we're in ;; 'check' mode, this must fail. @@ -945,10 +945,10 @@ #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'multiple-build c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result on the second run. (current-build-output-port (current-error-port)) -- cgit 1.4.1 From 3e223a22a70138b8c57e742ad8ec737131249820 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 10:05:31 +0100 Subject: packages: Add 'package-closure'. * guix/packages.scm (package-closure): New procedure. * tests/packages.scm ("package-closure"): New test. --- guix/packages.scm | 25 ++++++++++++++++++++++++- tests/packages.scm | 23 +++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) (limited to 'tests/packages.scm') diff --git a/guix/packages.scm b/guix/packages.scm index e4c2ac3be5..f191327718 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost @@ -133,6 +133,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-closure default-guile default-guile-derivation @@ -798,6 +799,28 @@ dependencies are known to build on SYSTEM." "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) +(define* (package-closure packages #:key (system (%current-system))) + "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of +packages they depend on, recursively." + (let loop ((packages packages) + (visited vlist-null) + (closure (list->setq packages))) + (match packages + (() + (set->list closure)) + ((package . rest) + (if (vhash-assq package visited) + (loop rest visited closure) + (let* ((bag (package->bag package system)) + (dependencies (filter-map (match-lambda + ((label (? package? package) . _) + package) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append dependencies rest) + (vhash-consq package #t visited) + (fold set-insert closure dependencies)))))))) + (define* (package-mapping proc #:optional (cut? (const #f))) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion diff --git a/tests/packages.scm b/tests/packages.scm index 29e5e4103c..e5704ae4b9 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -249,6 +249,28 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(test-assert "package-closure" + (let-syntax ((dummy-package/no-implicit + (syntax-rules () + ((_ name rest ...) + (package + (inherit (dummy-package name rest ...)) + (build-system trivial-build-system)))))) + (let* ((a (dummy-package/no-implicit "a")) + (b (dummy-package/no-implicit "b" + (propagated-inputs `(("a" ,a))))) + (c (dummy-package/no-implicit "c" + (inputs `(("a" ,a))))) + (d (dummy-package/no-implicit "d" + (native-inputs `(("b" ,b))))) + (e (dummy-package/no-implicit "e" + (inputs `(("c" ,c) ("d" ,d)))))) + (lset= eq? + (list a b c d e) + (package-closure (list e)) + (package-closure (list e d)) + (package-closure (list e c b)))))) + (test-equal "origin-actual-file-name" "foo-1.tar.gz" (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz")))) @@ -1180,4 +1202,5 @@ ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1) ;;; End: -- cgit 1.4.1