store-copy: 'read-reference-graph' returns a list of records.

The previous implementation of 'read-reference-graph' was good enough
for many use cases, but it discarded the graph structure, which is
useful information in some cases.

* guix/build/store-copy.scm (<store-info>): New record type.
(read-reference-graph): Rewrite to return a list of <store-info>.
(closure-size, populate-store): Adjust accordingly.
* gnu/services/base.scm (references-file): Adjust accordingly.
* gnu/system/vm.scm (system-docker-image): Likewise.
* guix/scripts/pack.scm (squashfs-image, docker-image): Likewise.
* tests/gexp.scm ("gexp->derivation #:references-graphs"): Likewise.

5 files changed, 128 insertions, 30 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index b34bb7132b..68411439db 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1592,8 +1592,9 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
 
                            (call-with-output-file #$output
                              (lambda (port)
-                               (write (call-with-input-file "graph"
-                                        read-reference-graph)
+                               (write (map store-info-item
+                                           (call-with-input-file "graph"
+                                             read-reference-graph))
                                       port)))))
                      #:options `(#:local-build? #f
                                  #:references-graphs (("graph" ,item))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 544c0e294d..4aea53d1cd 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -466,8 +466,10 @@ should set REGISTER-CLOSURES? to #f."
                 (build-docker-image
                  (string-append "/xchg/" #$name) ;; The output file.
                  (cons* root-directory
-                        (call-with-input-file (string-append "/xchg/" #$graph)
-                          read-reference-graph))
+                        (map store-info-item
+                             (call-with-input-file
+                                 (string-append "/xchg/" #$graph)
+                               read-reference-graph)))
                  #$os-drv
                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
                  #:creation-time (make-time time-utc 0 1)
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index fe2eb6f69a..bad1c09cba 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,10 +18,21 @@
 
 (define-module (guix build store-copy)
   #:use-module (guix build utils)
+  #:use-module (guix sets)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 ftw)
-  #:export (read-reference-graph
+  #:use-module (ice-9 vlist)
+  #:export (store-info?
+            store-info-item
+            store-info-deriver
+            store-info-references
+
+            read-reference-graph
+
             closure-size
             populate-store))
 
@@ -34,19 +45,94 @@
 ;;;
 ;;; Code:
 
+;; Information about a store item as produced by #:references-graphs.
+(define-record-type <store-info>
+  (store-info item deriver references)
+  store-info?
+  (item        store-info-item)                   ;string
+  (deriver     store-info-deriver)                ;#f | string
+  (references  store-info-references))            ;?
+
+;; TODO: Factorize with that in (guix store).
+(define (topological-sort nodes edges)
+  "Return NODES in topological order according to EDGES.  EDGES must be a
+one-argument procedure that takes a node and returns the nodes it is connected
+to."
+  (define (traverse)
+    ;; Do a simple depth-first traversal of all of PATHS.
+    (let loop ((nodes nodes)
+               (visited (setq))
+               (result '()))
+      (match nodes
+        ((head tail ...)
+         (if (set-contains? visited head)
+             (loop tail visited result)
+             (call-with-values
+                 (lambda ()
+                   (loop (edges head)
+                         (set-insert head visited)
+                         result))
+               (lambda (visited result)
+                 (loop tail visited (cons head result))))))
+        (()
+         (values visited result)))))
+
+  (call-with-values traverse
+    (lambda (_ result)
+      (reverse result))))
+
 (define (read-reference-graph port)
-  "Return a list of store paths from the reference graph at PORT.
-The data at PORT is the format produced by #:references-graphs."
-  (let loop ((line   (read-line port))
-             (result '()))
-    (cond ((eof-object? line)
-           (delete-duplicates result))
-          ((string-prefix? "/" line)
-           (loop (read-line port)
-                 (cons line result)))
-          (else
-           (loop (read-line port)
-                 result)))))
+  "Read the reference graph as produced by #:references-graphs from PORT and
+return it as a list of <store-info> records in topological order--i.e., leaves
+come first.  IOW, store items in the resulting list can be registered in the
+order in which they appear.
+
+The reference graph format consists of sequences of lines like this:
+
+     FILE
+     DERIVER
+     NUMBER-OF-REFERENCES
+     REF1
+     ...
+     REFN
+
+It is meant as an internal format."
+  (let loop ((result '())
+             (table vlist-null)
+             (referrers vlist-null))
+    (match (read-line port)
+      ((? eof-object?)
+       ;; 'guix-daemon' gives us something that's in "reverse topological
+       ;; order"--i.e., leaves (items with zero references) come last.  Here
+       ;; we compute the topological order that we want: leaves come first.
+       (let ((unreferenced? (lambda (item)
+                              (let ((referrers (vhash-fold* cons '()
+                                                            (store-info-item item)
+                                                            referrers)))
+                                (or (null? referrers)
+                                    (equal? (list item) referrers))))))
+         (topological-sort (filter unreferenced? result)
+                           (lambda (item)
+                             (map (lambda (item)
+                                    (match (vhash-assoc item table)
+                                      ((_ . node) node)))
+                                  (store-info-references item))))))
+      (item
+       (let* ((deriver (match (read-line port)
+                         ("" #f)
+                         (line line)))
+              (count   (string->number (read-line port)))
+              (refs    (unfold-right (cut >= <> count)
+                                     (lambda (n)
+                                       (read-line port))
+                                     1+
+                                     0))
+              (item    (store-info item deriver refs)))
+         (loop (cons item result)
+               (vhash-cons (store-info-item item) item table)
+               (fold (cut vhash-cons <> item <>)
+                     referrers
+                     refs)))))))
 
 (define (file-size file)
   "Return the size of bytes of FILE, entering it if FILE is a directory."
@@ -72,7 +158,8 @@ The data at PORT is the format produced by #:references-graphs."
   "Return an estimate of the size of the closure described by
 REFERENCE-GRAPHS, a list of reference-graph files."
   (define (graph-from-file file)
-    (call-with-input-file file read-reference-graph))
+    (map store-info-item
+         (call-with-input-file file read-reference-graph)))
 
   (define items
     (delete-duplicates (append-map graph-from-file reference-graphs)))
@@ -88,7 +175,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
   (define (things-to-copy)
     ;; Return the list of store files to copy to the image.
     (define (graph-from-file file)
-      (call-with-input-file file read-reference-graph))
+      (map store-info-item
+           (call-with-input-file file read-reference-graph)))
 
     (delete-duplicates (append-map graph-from-file reference-graphs)))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 76729d8e10..78bfd01eff 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -251,8 +251,9 @@ added to the pack."
           ;; ancestor directories and only keeps the basename.  We fix this
           ;; in the following invocations of mksquashfs.
           (apply invoke "mksquashfs"
-                 `(,@(call-with-input-file "profile"
-                       read-reference-graph)
+                 `(,@(map store-info-item
+                          (call-with-input-file "profile"
+                            read-reference-graph))
                    ,#$output
 
                    ;; Do not perform duplicate checking because we
@@ -352,8 +353,9 @@ the image."
             (setenv "PATH" (string-append #$archiver "/bin"))
 
             (build-docker-image #$output
-                                (call-with-input-file "profile"
-                                  read-reference-graph)
+                                (map store-info-item
+                                     (call-with-input-file "profile"
+                                       read-reference-graph))
                                 #$profile
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:symlinks '#$symlinks
diff --git a/tests/gexp.scm b/tests/gexp.scm
index a560adfc5c..83fe811546 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -615,6 +615,7 @@
                                                 `(("graph" ,two))
                                                 #:modules
                                                 '((guix build store-copy)
+                                                  (guix sets)
                                                   (guix build utils))))
                          (ok? (built-derivations (list drv)))
                          (out -> (derivation->output-path drv)))
@@ -815,21 +816,25 @@
        (two (gexp->derivation "two"
                               #~(symlink #$one #$output:chbouib)))
        (build -> (with-imported-modules '((guix build store-copy)
+                                          (guix sets)
                                           (guix build utils))
                    #~(begin
                        (use-modules (guix build store-copy))
                        (with-output-to-file #$output
                          (lambda ()
-                           (write (call-with-input-file "guile"
-                                    read-reference-graph))))
+                           (write (map store-info-item
+                                       (call-with-input-file "guile"
+                                         read-reference-graph)))))
                        (with-output-to-file #$output:one
                          (lambda ()
-                           (write (call-with-input-file "one"
-                                    read-reference-graph))))
+                           (write (map store-info-item
+                                       (call-with-input-file "one"
+                                         read-reference-graph)))))
                        (with-output-to-file #$output:two
                          (lambda ()
-                           (write (call-with-input-file "two"
-                                    read-reference-graph)))))))
+                           (write (map store-info-item
+                                       (call-with-input-file "two"
+                                         read-reference-graph))))))))
        (drv (gexp->derivation "ref-graphs" build
                               #:references-graphs `(("one" ,one)
                                                     ("two" ,two "chbouib")