diff options
| -rw-r--r-- | guix/store.scm | 41 | ||||
| -rw-r--r-- | tests/store.scm | 35 |
2 files changed, 76 insertions, 0 deletions
diff --git a/guix/store.scm b/guix/store.scm index 8746d3c2d6..56aa38ba8d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -93,6 +94,7 @@ path-info-nar-size references + references/substitutes requisites referrers optimize-store @@ -724,6 +726,45 @@ error if there is no such root." "Return the list of references of PATH." store-path-list)) +(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 +information for one of ITEMS is missing." + (let* ((local-refs (map (lambda (item) + (guard (c ((nix-protocol-error? c) #f)) + (references store item))) + items)) + (missing (fold-right (lambda (item local-ref result) + (if local-ref + result + (cons item result))) + '() + items local-refs)) + + ;; Query all the substitutes at once to minimize the cost of + ;; launching 'guix substitute' and making HTTP requests. + (substs (substitutable-path-info store missing))) + (when (< (length substs) (length missing)) + (raise (condition (&nix-protocol-error + (message "cannot determine \ +the list of references") + (status 1))))) + + ;; Intersperse SUBSTS and LOCAL-REFS. + (let loop ((local-refs local-refs) + (remote-refs (map substitutable-references substs)) + (result '())) + (match local-refs + (() + (reverse result)) + ((#f tail ...) + (match remote-refs + ((remote rest ...) + (loop tail rest (cons remote result))))) + ((head tail ...) + (loop tail remote-refs (cons head result))))))) + (define* (fold-path store proc seed path #:optional (relatives (cut references store <>))) "Call PROC for each of the RELATIVES of PATH, exactly once, and return the diff --git a/tests/store.scm b/tests/store.scm index de070eab23..3d32d52758 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -196,6 +196,41 @@ (null? (references %store t1)) (null? (referrers %store t2))))) +(test-assert "references/substitutes missing reference info" + (with-store s + (set-build-options s #:use-substitutes? #f) + (guard (c ((nix-protocol-error? c) #t)) + (let* ((b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b '("--help") + #:inputs `((,b))))) + (references/substitutes s (list (derivation->output-path d) b)))))) + +(test-assert "references/substitutes with substitute info" + (with-store s + (set-build-options s #:use-substitutes? #t) + (let* ((t1 (add-text-to-store s "random1" (random-text))) + (t2 (add-text-to-store s "random2" (random-text) + (list t1))) + (t3 (add-text-to-store s "build" "echo -n $t2 > $out")) + (b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b `("-e" ,t3) + #:inputs `((,b) (,t3) (,t2)) + #:env-vars `(("t2" . ,t2)))) + (o (derivation->output-path d))) + (with-derivation-narinfo d + (sha256 => (sha256 (string->utf8 t2))) + (references => (list t2)) + + (equal? (references/substitutes s (list o t3 t2 t1)) + `((,t2) ;refs of O + () ;refs of T3 + (,t1) ;refs of T2 + ())))))) ;refs of T1 + (test-assert "requisites" (let* ((t1 (add-text-to-store %store "random1" (random-text) '())) |