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:
(define (read-reference-graph port) ;; Information about a store item as produced by #:references-graphs.
"Return a list of store paths from the reference graph at PORT. (define-record-type <store-info>
The data at PORT is the format produced by #:references-graphs." (store-info item deriver references)
(let loop ((line (read-line port)) 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 '())) (result '()))
(cond ((eof-object? line) (match nodes
(delete-duplicates result)) ((head tail ...)
((string-prefix? "/" line) (if (set-contains? visited head)
(loop (read-line port) (loop tail visited result)
(cons line result))) (call-with-values
(else (lambda ()
(loop (read-line port) (loop (edges head)
result))))) (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) (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)))

8
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
(map store-info-item
(call-with-input-file "profile" (call-with-input-file "profile"
read-reference-graph) 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")