summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-03-04 17:57:04 +0100
committerLudovic Courtès <ludo@gnu.org>2016-03-05 00:19:10 +0100
commit6581ec9ab9ccb82cf1ddd7cf78c02975954bf8bf (patch)
tree19c04ecf5cb3640115be7cde5559ee0e8ba75ef8
parent7bfeb9df20906fd80c91fecccac3f56d0da05238 (diff)
store: Add 'references/substitutes'.
* guix/store.scm (references/substitutes): New procedure. * tests/store.scm ("references/substitutes missing reference info") ("references/substitutes with substitute info"): New tests.
-rw-r--r--guix/store.scm41
-rw-r--r--tests/store.scm35
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) '()))