From c40bf5816cb3ffb59920a61f71bd34b53cac3637 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:41:18 +0100 Subject: store: Add 'map/accumulate-builds'. * guix/store.scm (): New record type. (build-accumulator, map/accumulate-builds, mapm/accumulate-builds): New procedures. * tests/store.scm ("map/accumulate-builds", "mapm/accumulate-builds"): New tests. --- tests/store.scm | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index b61a981b28..0458a34746 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -412,6 +412,42 @@ (build-derivations %store (list d2)) 'fail))) +(test-assert "map/accumulate-builds" + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d1 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s))) + (d2 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text)) + ("bar" . "baz")) + #:sources (list b s)))) + (with-build-handler (lambda (continue store things mode) + (equal? (map derivation-file-name (list d1 d2)) + things)) + (map/accumulate-builds %store + (lambda (drv) + (build-derivations %store (list drv)) + (add-to-store %store "content-addressed" + #t "sha256" + (derivation->output-path drv))) + (list d1 d2))))) + +(test-assert "mapm/accumulate-builds" + (let* ((d1 (run-with-store %store + (gexp->derivation "foo" #~(mkdir #$output)))) + (d2 (run-with-store %store + (gexp->derivation "bar" #~(mkdir #$output))))) + (with-build-handler (lambda (continue store things mode) + (equal? (map derivation-file-name (pk 'zz (list d1 d2))) + (pk 'XX things))) + (run-with-store %store + (mapm/accumulate-builds built-derivations `((,d1) (,d2))))))) + (test-assert "topologically-sorted, one item" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) -- cgit 1.4.1 From a187cc562890895ad41dfad00eb1d5c4a4b00936 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 22:11:54 +0200 Subject: guix package: 'transaction-upgrade-entry' swallows build requests. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes a regression introduced in 131f50cdc9dbb7183023f4dae759876a9e700bef whereby the install/upgrade message would not be displayed: $ guix upgrade -n 2.1 MB would be downloaded: /gnu/store/…-something-1.2 /gnu/store/…-its-dependency-2.3 This is because we'd directly abort from 'transaction-upgrade-entry' to the build handler of 'build-notifier'. * guix/scripts/package.scm (transaction-upgrade-entry): Call 'string=?' expression in 'with-build-handler'. * tests/packages.scm ("transaction-upgrade-entry, grafts"): New test. --- guix/scripts/package.scm | 14 +++++++++++--- tests/packages.scm | 24 ++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index be2e67997e..cafa62c3f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -234,11 +234,19 @@ non-zero relevance score." transaction) ((=) (let* ((new (package->manifest-entry* pkg output))) + ;; Here we want to determine whether the NEW actually + ;; differs from ENTRY, but we need to intercept + ;; 'build-things' calls because they would prevent us from + ;; displaying the list of packages to install/upgrade + ;; upfront. Thus, if lowering NEW triggers a build (due + ;; to grafts), assume NEW differs from ENTRY. + ;; XXX: When there are propagated inputs, assume we need to ;; upgrade the whole entry. - (if (and (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry)) + (if (and (with-build-handler (const #f) + (string=? (manifest-entry-item + (lower-manifest-entry* new)) + (manifest-entry-item entry))) (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry diff --git a/tests/packages.scm b/tests/packages.scm index 1ff35ec9c4..c2ec1f2c24 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -148,6 +148,30 @@ (string=? (manifest-pattern-version pattern) "1") (string=? (manifest-pattern-output pattern) "out"))))))) +(test-assert "transaction-upgrade-entry, grafts" + ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't + ;; try to build stuff. + (with-build-handler (const 'failed!) + (parameterize ((%graft? #t)) + (let* ((old (dummy-package "foo" (version "1"))) + (bar (dummy-package "bar" (version "0") + (replacement old))) + (new (dummy-package "foo" (version "1") + (inputs `(("bar" ,bar))))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list new))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "foo" "1" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit 1.4.1 From b9c79cae53f5f828e078ac5aafc2d80fa3204aae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 23:19:38 +0200 Subject: guix package: Add 'transaction-upgrade-entry' test. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades, equivalent package"): New test. --- tests/packages.scm | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'tests') diff --git a/tests/packages.scm b/tests/packages.scm index c2ec1f2c24..d0befbe45d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -109,6 +109,19 @@ (manifest-transaction))))) (manifest-transaction-null? tx))) +(test-assert "transaction-upgrade-entry, zero upgrades, equivalent package" + (let* ((old (dummy-package "foo" (version "1"))) + (drv (package-derivation %store old)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list old))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (derivation->output-path drv))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) -- cgit 1.4.1 From a357849f5b1314c2a35efeee237645b9b08c39f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 23:34:48 +0200 Subject: guix package: Do not misdiagnose upgrades when there are propagated inputs. Fixes . Reported by Andy Tai . * guix/profiles.scm (list=?, manifest-entry=?): New procedures. * guix/scripts/package.scm (transaction-upgrade-entry): In the '=' case, use 'manifest-entry=?' to determine whether it's an upgrade. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades, propagated inputs"): New test. --- guix/profiles.scm | 29 +++++++++++++++++++++++++++++ guix/scripts/package.scm | 11 +++-------- tests/packages.scm | 22 ++++++++++++++++++++++ 3 files changed, 54 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index e3bbc6dd6d..8aa76a3537 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -89,6 +89,8 @@ manifest-entry-properties lower-manifest-entry + manifest-entry=? + manifest-pattern manifest-pattern? manifest-pattern-name @@ -217,6 +219,33 @@ (output manifest-pattern-output ; string | #f (default "out"))) +(define (list=? = lst1 lst2) + "Return true if LST1 and LST2 have the same length and their elements are +pairwise equal per =." + (match lst1 + (() + (null? lst2)) + ((head1 . tail1) + (match lst2 + ((head2 . tail2) + (and (= head1 head2) (list=? = tail1 tail2))) + (() + #f))))) + +(define (manifest-entry=? entry1 entry2) + "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties' +field." + (match entry1 + (($ name1 version1 output1 item1 dependencies1 paths1) + (match entry2 + (($ name2 version2 output2 item2 dependencies2 paths2) + (and (string=? name1 name2) + (string=? version1 version2) + (string=? output1 output2) + (equal? item1 item2) ;XXX: could be vs. store item + (equal? paths1 paths2) + (list=? manifest-entry=? dependencies1 dependencies2))))))) + (define (manifest-transitive-entries manifest) "Return the entries of MANIFEST along with their propagated inputs, recursively." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index cafa62c3f3..badb1dcd38 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -240,14 +240,9 @@ non-zero relevance score." ;; displaying the list of packages to install/upgrade ;; upfront. Thus, if lowering NEW triggers a build (due ;; to grafts), assume NEW differs from ENTRY. - - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (with-build-handler (const #f) - (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry))) - (null? (package-propagated-inputs pkg))) + (if (with-build-handler (const #f) + (manifest-entry=? (lower-manifest-entry* new) + entry)) transaction (manifest-transaction-install-entry new transaction))))))))) diff --git a/tests/packages.scm b/tests/packages.scm index d0befbe45d..7a8b5e4a2d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -122,6 +122,28 @@ (manifest-transaction))))) (manifest-transaction-null? tx))) +(test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs" + ;; Properly detect equivalent packages even when they have propagated + ;; inputs. See . + (let* ((dep (dummy-package "dep" (version "2"))) + (old (dummy-package "foo" (version "1") + (propagated-inputs `(("dep" ,dep))))) + (drv (package-derivation %store old)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list old))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (derivation->output-path drv)) + (dependencies + (list (manifest-entry + (inherit (package->manifest-entry dep)) + (item (derivation->output-path + (package-derivation %store dep))))))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) -- cgit 1.4.1 From b771e0176a9cafaaf5fc279a7f3e5e3033b5fb4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Mar 2020 00:05:02 +0200 Subject: pack: Adjust test to '--dry-run' changes. This is a followup to 131f50cdc9dbb7183023f4dae759876a9e700bef. * tests/guix-pack.sh: Use '--no-grafts' in conjunction with '-n' and '-d'. --- tests/guix-pack.sh | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 7a0f3400c3..14e3cda361 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -1,6 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2018 Chris Marusich -# Copyright © 2018, 2019 Ludovic Courtès +# Copyright © 2018, 2019, 2020 Ludovic Courtès # # This file is part of GNU Guix. # @@ -105,8 +105,8 @@ guix pack -R --dry-run --bootstrap -S /mybin=bin guile-bootstrap # Make sure package transformation options are honored. mkdir -p "$test_directory" -drv1="`guix pack -n guile 2>&1 | grep pack.*\.drv`" -drv2="`guix pack -n --with-source=guile=$test_directory guile 2>&1 | grep pack.*\.drv`" +drv1="`guix pack --no-grafts -n guile 2>&1 | grep pack.*\.drv`" +drv2="`guix pack --no-grafts -n --with-source=guile=$test_directory guile 2>&1 | grep pack.*\.drv`" test -n "$drv1" test "$drv1" != "$drv2" @@ -117,6 +117,6 @@ EOF cat > "$test_directory/manifest2.scm" <manifest '("emacs")) EOF -drv="`guix pack -nd -m "$test_directory/manifest1.scm" -m "$test_directory/manifest2.scm"`" -guix gc -R "$drv" | grep `guix build guile -nd` -guix gc -R "$drv" | grep `guix build emacs -nd` +drv="`guix pack --no-grafts -d -m "$test_directory/manifest1.scm" -m "$test_directory/manifest2.scm"`" +guix gc -R "$drv" | grep `guix build guile -d --no-grafts` +guix gc -R "$drv" | grep `guix build emacs -d --no-grafts` -- cgit 1.4.1 From 8ed597f4a261fe188de82cd1f5daed83dba948eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 17:36:31 +0200 Subject: store: 'with-store' doesn't close the store upon abort. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Marius Bakke and 白い熊. Regression introduced with the first uses of 'with-build-handler' in commit 62195b9a8fd6846117c5d7698842748300d13e31 and subsequent. * guix/store.scm (call-with-store): Use 'catch #t' instead of 'dynamic-wind'. This ensures STORE remains open when a non-local exit other than an exception occurs, such as an abort to the build handler prompt. * tests/store.scm ("with-build-handler + with-store"): New test. --- guix/store.scm | 12 +++++++----- tests/store.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/guix/store.scm b/guix/store.scm index ca8c0e5ef8..1dd5c9545b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,14 +623,16 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (dynamic-wind - (const #f) + (catch #t (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - (proc store))) - (lambda () - (false-if-exception (close-connection store)))))) + (let ((result (proc store))) + (close-connection store) + result))) + (lambda (key . args) + (close-connection store) + (apply throw key args))))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; diff --git a/tests/store.scm b/tests/store.scm index 0458a34746..0e80ccc239 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -412,6 +412,33 @@ (build-derivations %store (list d2)) 'fail))) +(test-equal "with-build-handler + with-store" + 'success + ;; Check that STORE remains valid when the build handler invokes CONTINUE, + ;; even though 'with-build-handler' is outside the dynamic extent of + ;; 'with-store'. + (with-build-handler (lambda (continue store things mode) + (match things + ((drv) + (and (string-suffix? "thingie.drv" drv) + (not (port-closed? + (store-connection-socket store))) + (continue #t))))) + (with-store store + (let* ((b (add-text-to-store store "build" "echo $foo > $out" '())) + (s (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation store "thingie" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s)))) + (build-derivations store (list d)) + + ;; Here STORE's socket should still be open. + (and (valid-path? store (derivation->output-path d)) + 'success))))) + (test-assert "map/accumulate-builds" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" -- cgit 1.4.1 From 3cea55078857ecd8ca67fd7cf4eaebb13fb6d9d3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 18:50:03 +0200 Subject: tests: Adjust '--with-commit' test for tags. This is a followup to efa578ecaece67366b4b0e2266de7c2faaa4ae54. * tests/guix-build-branch.sh: Adjust '--with-commit=guile-gcrypt=v0.1.0' test to expect the tag ID rather than the commit ID. --- tests/guix-build-branch.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index 2556a0cdb9..c5b07e07c6 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2018, 2019 Ludovic Courtès +# Copyright © 2018, 2019, 2020 Ludovic Courtès # # This file is part of GNU Guix. # @@ -54,7 +54,7 @@ test "$v0_1_0_drv" != "$orig_drv" v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`" guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-0.1.0 -guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-9e3eacd +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the tag ID test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" -- cgit 1.4.1 From 10af34cd7f1f4f9fb50db826d06233c83a9c0439 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 20 Apr 2020 10:56:23 +0200 Subject: tests: Update expected values for package->code. Reported by janneke on IRC. * tests/print.scm: Update expected package definitions produced by package->code. --- tests/print.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/tests/print.scm b/tests/print.scm index d4b2cca93f..3386590d3a 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +21,7 @@ #:use-module (guix build-system gnu) #:use-module (guix download) #:use-module (guix packages) - #:use-module (guix licenses) + #:use-module ((guix licenses) #:prefix license:) #:use-module (srfi srfi-64)) (define-syntax-rule (define-with-source object source expr) @@ -42,11 +42,11 @@ (sha256 (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) - (build-system gnu-build-system) + (build-system (@ (guix build-system gnu) gnu-build-system)) (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") - (license gpl3+))) + (license license:gpl3+))) (define-with-source pkg-with-inputs pkg-with-inputs-source (package @@ -59,20 +59,20 @@ (sha256 (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) - (build-system gnu-build-system) + (build-system (@ (guix build-system gnu) gnu-build-system)) (inputs `(("coreutils" ,(@ (gnu packages base) coreutils)) ("glibc" ,(@ (gnu packages base) glibc) "debug"))) (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") - (license gpl3+))) + (license license:gpl3+))) (test-equal "simple package" - pkg-source + `(define-public test ,pkg-source) (package->code pkg)) (test-equal "package with inputs" - pkg-with-inputs-source + `(define-public test ,pkg-with-inputs-source) (package->code pkg-with-inputs)) (test-end "print") -- cgit 1.4.1 From 2520059bdb43fa1663ce102f3f4c442d4918c32b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Apr 2020 14:30:38 +0200 Subject: pack: 'guix pack -R' wrapper correctly reports exit code. Fixes . Reported by Jan (janneke) Nieuwenhuizen . * gnu/packages/aux-files/run-in-namespace.c (main): In the 'default' case, check 'WIFEXITED (status)' and exit with the corresponding code in that case. Exit with 255 in other cases. * tests/guix-pack-relocatable.sh: Add test. --- gnu/packages/aux-files/run-in-namespace.c | 10 ++++++++-- tests/guix-pack-relocatable.sh | 6 +++++- 2 files changed, 13 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/gnu/packages/aux-files/run-in-namespace.c b/gnu/packages/aux-files/run-in-namespace.c index 551f4db88a..160f7da1c8 100644 --- a/gnu/packages/aux-files/run-in-namespace.c +++ b/gnu/packages/aux-files/run-in-namespace.c @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2018, 2019 Ludovic Courtès + Copyright (C) 2018, 2019, 2020 Ludovic Courtès This file is part of GNU Guix. @@ -343,7 +343,13 @@ Please refer to the 'guix pack' documentation for more information.\n"); chdir ("/"); /* avoid EBUSY */ rm_rf (new_root); free (new_root); - exit (status); + + if (WIFEXITED (status)) + exit (WEXITSTATUS (status)); + else + /* Abnormal termination cannot really be reproduced, so exit + with 255. */ + exit (255); } } } diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index e93610eedc..a3fd45623c 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2018, 2019 Ludovic Courtès +# Copyright © 2018, 2019, 2020 Ludovic Courtès # # This file is part of GNU Guix. # @@ -72,6 +72,10 @@ then # mounting an empty file system on top of it. That way, we exercise the # wrapper code that creates the user namespace and bind-mounts the store. unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --version > "$test_directory/output"' + + # Check whether the exit code is preserved. + if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --does-not-exist'; + then false; else true; fi else # Run the relocatable 'sed' in the current namespaces. This is a weak # test because we're going to access store items from the host store. -- cgit 1.4.1 From ef674a24c527eaf54801707d34dbf5d12ec139cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Apr 2020 15:43:43 +0200 Subject: profiles: Add lowerable record type. * guix/profiles.scm (): New record type. * tests/profiles.scm (""): New test. --- guix/profiles.scm | 36 ++++++++++++++++++++++++++++++++++++ tests/profiles.scm | 13 ++++++++++++- 2 files changed, 48 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index 88606fa4ce..ab265cce62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -125,6 +125,15 @@ profile-derivation profile-search-paths + profile + profile? + profile-name + profile-content + profile-hooks + profile-locales? + profile-allow-collisions? + profile-relative-symlinks? + generation-number generation-profile generation-numbers @@ -1656,6 +1665,33 @@ are cross-built for TARGET." . ,(length (manifest-entries manifest)))))))) +;; Declarative profile. +(define-record-type* profile make-profile + profile? + (name profile-name (default "profile")) ;string + (content profile-content) ; + (hooks profile-hooks ;list of procedures + (default %default-profile-hooks)) + (locales? profile-locales? ;Boolean + (default #t)) + (allow-collisions? profile-allow-collisions? ;Boolean + (default #f)) + (relative-symlinks? profile-relative-symlinks? ;Boolean + (default #f))) + +(define-gexp-compiler (profile-compiler (profile ) system target) + "Compile PROFILE to a derivation." + (match profile + (($ name manifest hooks + locales? allow-collisions? relative-symlinks?) + (profile-derivation manifest + #:name name + #:hooks hooks + #:locales? locales? + #:allow-collisions? allow-collisions? + #:relative-symlinks? relative-symlinks? + #:system system #:target target)))) + (define* (profile-search-paths profile #:optional (manifest (profile-manifest profile)) #:key (getenv (const #f))) diff --git a/tests/profiles.scm b/tests/profiles.scm index 21c912a532..055924ba3e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -223,6 +223,17 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "" + (mlet* %store-monad + ((entry -> (package->manifest-entry %bootstrap-guile)) + (profile -> (profile (hooks '()) (locales? #f) + (content (manifest (list entry))))) + (drv (lower-object profile)) + (profile -> (derivation->output-path drv)) + (bindir -> (string-append profile "/bin")) + (_ (built-derivations (list drv)))) + (return (file-exists? (string-append bindir "/guile"))))) + (test-assertm "profile-derivation relative symlinks, one entry" (mlet* %store-monad ((entry -> (package->manifest-entry %bootstrap-guile)) -- cgit 1.4.1 From 5dfe02c60767a633c67f7f6fc9557b54b3c99b63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Apr 2020 22:12:59 +0200 Subject: tests: Remove trailing commas in JSON tests. These commas are rejected by Guile-JSON 3.5.0. * tests/crate.scm (test-foo-dependencies) (test-root-dependencies, test-intermediate-1-dependencies) (test-intermediate-2-dependencies): Remove trailing commas. * tests/gem.scm (test-bar-json): Likewise. * tests/pypi.scm (test-json): Likewise. --- tests/crate.scm | 23 ++++++++++++----------- tests/gem.scm | 2 +- tests/pypi.scm | 7 ++++--- 3 files changed, 17 insertions(+), 15 deletions(-) (limited to 'tests') diff --git a/tests/crate.scm b/tests/crate.scm index aa51faebf9..61a04f986b 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -55,7 +55,7 @@ \"dependencies\": [ { \"crate_id\": \"bar\", - \"kind\": \"normal\", + \"kind\": \"normal\" } ] }") @@ -87,20 +87,20 @@ \"dependencies\": [ { \"crate_id\": \"intermediate-1\", - \"kind\": \"normal\", + \"kind\": \"normal\" }, { \"crate_id\": \"intermediate-2\", - \"kind\": \"normal\", + \"kind\": \"normal\" } { \"crate_id\": \"leaf-alice\", - \"kind\": \"normal\", + \"kind\": \"normal\" }, { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\", - }, + \"kind\": \"normal\" + } ] }") @@ -131,15 +131,15 @@ \"dependencies\": [ { \"crate_id\": \"intermediate-2\", - \"kind\": \"normal\", + \"kind\": \"normal\" }, { \"crate_id\": \"leaf-alice\", - \"kind\": \"normal\", + \"kind\": \"normal\" }, { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\", + \"kind\": \"normal\" } ] }") @@ -171,8 +171,8 @@ \"dependencies\": [ { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\", - }, + \"kind\": \"normal\" + } ] }") @@ -233,6 +233,7 @@ (define test-source-hash "") + (test-begin "crate") (test-equal "guix-package->crate-name" diff --git a/tests/gem.scm b/tests/gem.scm index 455fc15189..751bba656f 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -52,7 +52,7 @@ \"homepage_uri\": \"https://example.com\", \"dependencies\": { \"runtime\": [ - { \"name\": \"bundler\" }, + { \"name\": \"bundler\" } ] }, \"licenses\": null diff --git a/tests/pypi.scm b/tests/pypi.scm index 19af6e61fb..6788c8db3e 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -46,13 +46,13 @@ \"1.0.0\": [ { \"url\": \"https://example.com/foo-1.0.0.egg\", - \"packagetype\": \"bdist_egg\", + \"packagetype\": \"bdist_egg\" }, { \"url\": \"https://example.com/foo-1.0.0.tar.gz\", - \"packagetype\": \"sdist\", + \"packagetype\": \"sdist\" }, { \"url\": \"https://example.com/foo-1.0.0-py2.py3-none-any.whl\", - \"packagetype\": \"bdist_wheel\", + \"packagetype\": \"bdist_wheel\" } ] } @@ -120,6 +120,7 @@ Provides-Extra: testing Requires-Dist: pytest (>=3.1.0); extra == 'testing' ") + (test-begin "pypi") (test-equal "guix-package->pypi-name, old URL style" -- cgit 1.4.1