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.
This commit is contained in:
Ludovic Courtès
parent
f8f9f7cabc
commit
6892f0a247
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
||||
(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))
|
||||
;; 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 '()))
|
||||
(cond ((eof-object? line)
|
||||
(delete-duplicates result))
|
||||
((string-prefix? "/" line)
|
||||
(loop (read-line port)
|
||||
(cons line result)))
|
||||
(else
|
||||
(loop (read-line port)
|
||||
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)
|
||||
"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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(map store-info-item
|
||||
(call-with-input-file "profile"
|
||||
read-reference-graph)
|
||||
read-reference-graph))
|
||||
#$profile
|
||||
#:system (or #$target (utsname:machine (uname)))
|
||||
#:symlinks '#$symlinks
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue