futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

store: 'map/accumulate-builds' handler checks the store received.

Browse Source 
This is a followup to b19250eec6,
providing a proper fix for <https://issues.guix.gnu.org/46756>.

* guix/remote.scm (remote-eval): Revert b19250eec6.
* guix/store.scm (build-accumulator): Turn into a procedure.  Call
CONTINUE when the store is not eq? to the initial store.
(map/accumulate-builds): Adjust accordingly.
* tests/store.scm ("map/accumulate-builds and different store"): New test.
This commit is contained in:
Ludovic Courtès 2021-10-28 19:21:50 +02:00
parent 45b251fd04
commit 2015d3f042
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 41 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
guix/remote.scm
View File

@ -146,15 +146,6 @@ remote store."
sources)))
(mbegin %store-monad
((store-lift send-files) to-send remote #:recursive? #t)
;; Build handlers are not tied to a specific <store-connection>.
;; If a handler is already installed, it might want to go ahead
;; and build, but on the local <store-connection> instead of
;; REMOTE. To avoid that, install a build handler that does
;; nothing.
(return (with-build-handler (lambda (continue . _)
(continue #t))
(build-derivations remote inputs)))
(return (build-derivations remote inputs))
(return (close-connection remote))
(return (%remote-eval lowered session become-command)))))))

18
guix/store.scm
View File

@ -1349,11 +1349,14 @@ on the build output of a previous derivation."
(things unresolved-things)
(continuation unresolved-continuation))
(define (build-accumulator continue store things mode)
"This build handler accumulates THINGS and returns an <unresolved> object."
(if (= mode (build-mode normal))
(unresolved things continue)
(continue #t)))
(define (build-accumulator expected-store)
"Return a build handler that accumulates THINGS and returns an <unresolved>
object, only for build requests on EXPECTED-STORE."
(lambda (continue store things mode)
(if (and (eq? store expected-store)
(= mode (build-mode normal)))
(unresolved things continue)
(continue #t))))
(define* (map/accumulate-builds store proc lst
#:key (cutoff 30))
@ -1366,13 +1369,16 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes."
;; stumbling upon the same .drv build requests with many incoming edges.
;; See <https://bugs.gnu.org/49439>.
(define accumulator
(build-accumulator store))
(define-values (result rest)
(let loop ((lst lst)
(result '())
(unresolved 0))
(match lst
((head . tail)
(match (with-build-handler build-accumulator
(match (with-build-handler accumulator
(proc head))
((? unresolved? obj)
(if (>= unresolved cutoff)

28
tests/store.scm
View File

@ -490,6 +490,34 @@
(equal? (map derivation-file-name (drop d 16)) batch3)
lst)))))
(test-equal "map/accumulate-builds and different store"
'(d2) ;see <https://issues.guix.gnu.org/46756>
(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 "first"
s `("-e" ,b)
#:env-vars `(("foo" . ,(random-text)))
#:sources (list b s)))
(d2 (derivation %store "second"
s `("-e" ,b)
#:env-vars `(("foo" . ,(random-text))
("bar" . "baz"))
#:sources (list b s))))
(with-store alternate-store
(with-build-handler (lambda (continue store things mode)
;; If this handler is called, it means that
;; 'map/accumulate-builds' triggered a build,
;; which it shouldn't since the inner
;; 'build-derivations' call is for another store.
'failed)
(map/accumulate-builds %store
(lambda (drv)
(build-derivations alternate-store (list d2))
'd2)
(list d1))))))
(test-assert "mapm/accumulate-builds"
(let* ((d1 (run-with-store %store
(gexp->derivation "foo" #~(mkdir #$output))))