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.
This commit is contained in:
parent
7bfeb9df20
commit
6581ec9ab9
2 changed files with 76 additions and 0 deletions
|
@ -27,6 +27,7 @@
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-9 gnu)
|
#:use-module (srfi srfi-9 gnu)
|
||||||
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
|
@ -93,6 +94,7 @@
|
||||||
path-info-nar-size
|
path-info-nar-size
|
||||||
|
|
||||||
references
|
references
|
||||||
|
references/substitutes
|
||||||
requisites
|
requisites
|
||||||
referrers
|
referrers
|
||||||
optimize-store
|
optimize-store
|
||||||
|
@ -724,6 +726,45 @@ error if there is no such root."
|
||||||
"Return the list of references of PATH."
|
"Return the list of references of PATH."
|
||||||
store-path-list))
|
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
|
(define* (fold-path store proc seed path
|
||||||
#:optional (relatives (cut references store <>)))
|
#:optional (relatives (cut references store <>)))
|
||||||
"Call PROC for each of the RELATIVES of PATH, exactly once, and return the
|
"Call PROC for each of the RELATIVES of PATH, exactly once, and return the
|
||||||
|
|
|
@ -196,6 +196,41 @@
|
||||||
(null? (references %store t1))
|
(null? (references %store t1))
|
||||||
(null? (referrers %store t2)))))
|
(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"
|
(test-assert "requisites"
|
||||||
(let* ((t1 (add-text-to-store %store "random1"
|
(let* ((t1 (add-text-to-store %store "random1"
|
||||||
(random-text) '()))
|
(random-text) '()))
|
||||||
|
|
Reference in a new issue