nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 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 (call-with-output-file #$output
(lambda (port) (lambda (port)
(write (call-with-input-file "graph" (write (map store-info-item
read-reference-graph) (call-with-input-file "graph"
read-reference-graph))
port))))) port)))))
#:options `(#:local-build? #f #:options `(#:local-build? #f
#:references-graphs (("graph" ,item)))) #:references-graphs (("graph" ,item))))

6
gnu/system/vm.scm
View File

@ -466,8 +466,10 @@ should set REGISTER-CLOSURES? to #f."
(build-docker-image (build-docker-image
(string-append "/xchg/" #$name) ;; The output file. (string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory (cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph) (map store-info-item
read-reference-graph)) (call-with-input-file
(string-append "/xchg/" #$graph)
read-reference-graph)))
#$os-drv #$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1) #: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 ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,10 +18,21 @@
(define-module (guix build store-copy) (define-module (guix build store-copy)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix sets)
#:use-module (srfi srfi-1) #: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 rdelim)
#:use-module (ice-9 ftw) #: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 closure-size
populate-store)) populate-store))
@ -34,19 +45,94 @@
;;; ;;;
;;; Code: ;;; 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) (define (read-reference-graph port)
"Return a list of store paths from the reference graph at PORT. "Read the reference graph as produced by #:references-graphs from PORT and
The data at PORT is the format produced by #:references-graphs." return it as a list of <store-info> records in topological order--i.e., leaves
(let loop ((line (read-line port)) come first. IOW, store items in the resulting list can be registered in the
(result '())) order in which they appear.
(cond ((eof-object? line)
(delete-duplicates result)) The reference graph format consists of sequences of lines like this:
((string-prefix? "/" line)
(loop (read-line port) FILE
(cons line result))) DERIVER
(else NUMBER-OF-REFERENCES
(loop (read-line port) REF1
result))))) ...
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) (define (file-size file)
"Return the size of bytes of FILE, entering it if FILE is a directory." "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 "Return an estimate of the size of the closure described by
REFERENCE-GRAPHS, a list of reference-graph files." REFERENCE-GRAPHS, a list of reference-graph files."
(define (graph-from-file file) (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 (define items
(delete-duplicates (append-map graph-from-file reference-graphs))) (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) (define (things-to-copy)
;; Return the list of store files to copy to the image. ;; Return the list of store files to copy to the image.
(define (graph-from-file file) (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))) (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 ;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs. ;; in the following invocations of mksquashfs.
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(,@(call-with-input-file "profile" `(,@(map store-info-item
read-reference-graph) (call-with-input-file "profile"
read-reference-graph))
,#$output ,#$output
;; Do not perform duplicate checking because we ;; Do not perform duplicate checking because we
@ -352,8 +353,9 @@ the image."
(setenv "PATH" (string-append #$archiver "/bin")) (setenv "PATH" (string-append #$archiver "/bin"))
(build-docker-image #$output (build-docker-image #$output
(call-with-input-file "profile" (map store-info-item
read-reference-graph) (call-with-input-file "profile"
read-reference-graph))
#$profile #$profile
#:system (or #$target (utsname:machine (uname))) #:system (or #$target (utsname:machine (uname)))
#:symlinks '#$symlinks #:symlinks '#$symlinks

17
tests/gexp.scm
View File

@ -615,6 +615,7 @@
`(("graph" ,two)) `(("graph" ,two))
#:modules #:modules
'((guix build store-copy) '((guix build store-copy)
(guix sets)
(guix build utils)))) (guix build utils))))
(ok? (built-derivations (list drv))) (ok? (built-derivations (list drv)))
(out -> (derivation->output-path drv))) (out -> (derivation->output-path drv)))
@ -815,21 +816,25 @@
(two (gexp->derivation "two" (two (gexp->derivation "two"
#~(symlink #$one #$output:chbouib))) #~(symlink #$one #$output:chbouib)))
(build -> (with-imported-modules '((guix build store-copy) (build -> (with-imported-modules '((guix build store-copy)
(guix sets)
(guix build utils)) (guix build utils))
#~(begin #~(begin
(use-modules (guix build store-copy)) (use-modules (guix build store-copy))
(with-output-to-file #$output (with-output-to-file #$output
(lambda () (lambda ()
(write (call-with-input-file "guile" (write (map store-info-item
read-reference-graph)))) (call-with-input-file "guile"
read-reference-graph)))))
(with-output-to-file #$output:one (with-output-to-file #$output:one
(lambda () (lambda ()
(write (call-with-input-file "one" (write (map store-info-item
read-reference-graph)))) (call-with-input-file "one"
read-reference-graph)))))
(with-output-to-file #$output:two (with-output-to-file #$output:two
(lambda () (lambda ()
(write (call-with-input-file "two" (write (map store-info-item
read-reference-graph))))))) (call-with-input-file "two"
read-reference-graph))))))))
(drv (gexp->derivation "ref-graphs" build (drv (gexp->derivation "ref-graphs" build
#:references-graphs `(("one" ,one) #:references-graphs `(("one" ,one)
("two" ,two "chbouib") ("two" ,two "chbouib")