03/07: store: Add 'references/substitutes'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 6581ec9ab9ccb82cf1ddd7cf78c02975954bf8bf
Author: Ludovic Courtès <address@hidden>
Date:   Fri Mar 4 17:57:04 2016 +0100

    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.
---
 guix/store.scm  |   41 +++++++++++++++++++++++++++++++++++++++++
 tests/store.scm |   35 +++++++++++++++++++++++++++++++++++
 2 files changed, 76 insertions(+), 0 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index 8746d3c..56aa38b 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 de070ea..3d32d52 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) '()))