futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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 2018-06-04 22:06:34 +02:00
parent f8f9f7cabc
commit 6892f0a247
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 128 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gnu/services/base.scm
View File

@ -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))))

6
gnu/system/vm.scm
View File

@ -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)

120
guix/build/store-copy.scm
View File

@ -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)))

10
guix/scripts/pack.scm
View File

@ -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

17
tests/gexp.scm
View File

@ -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")