store: 'mapm/accumulate-builds' preserves '%current-target-system'.

Fixes <https://bugs.gnu.org/41182>.

* guix/store.scm (mapm/accumulate-builds): Pass #:system and #:target to
'run-with-store'.
* tests/store.scm ("mapm/accumulate-builds, %current-target-system"):
New test.
* tests/guix-pack.sh: Add 'guix pack -d --target' test.
This commit is contained in:
Ludovic Courtès 2020-05-14 16:53:42 +02:00
parent f52fbf7094
commit 80963744a2
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 28 additions and 1 deletions

View file

@ -1899,7 +1899,9 @@ (define (mapm/accumulate-builds mproc lst)
(values (map/accumulate-builds store
(lambda (obj)
(run-with-store store
(mproc obj)))
(mproc obj)
#:system (%current-system)
#:target (%current-target-system)))
lst)
store)))

View file

@ -40,6 +40,14 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
drv="`guix pack coreutils -d --no-grafts`"
guix gc -R "$drv" | grep "`guix build coreutils -d --no-grafts`"
# Compute the derivation of a cross-compiled pack. Make sure it refers to the
# cross-compiled package and not to the native package.
drv="`guix pack idutils -d --no-grafts --target=arm-linux-gnueabihf`"
guix gc -R "$drv" | \
grep "`guix build idutils --target=arm-linux-gnueabihf -d --no-grafts`"
if guix gc -R "$drv" | grep "`guix build idutils -d --no-grafts`";
then false; else true; fi
# Build a tarball with no compression.
guix pack --compression=none --bootstrap guile-bootstrap

View file

@ -475,6 +475,23 @@ (define (same? x y)
(run-with-store %store
(mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
(test-equal "mapm/accumulate-builds, %current-target-system"
(make-list 2 '("i586-pc-gnu" "i586-pc-gnu"))
;; Both the 'mapm' and 'mapm/accumulate-builds' procedures should see the
;; right #:target.
(run-with-store %store
(mlet %store-monad ((lst1 (mapm %store-monad
(lambda _
(current-target-system))
'(a b)))
(lst2 (mapm/accumulate-builds
(lambda _
(current-target-system))
'(a b))))
(return (list lst1 lst2)))
#:system system
#:target "i586-pc-gnu"))
(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)))