summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/services/base.scm5
-rw-r--r--gnu/system/vm.scm6
-rw-r--r--guix/build/store-copy.scm120
-rw-r--r--guix/scripts/pack.scm10
-rw-r--r--tests/gexp.scm17
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")