store-copy: 'populate-store' can optionally deduplicate files.
Until now deduplication was performed as an additional pass after copying files, which involve re-traversing all the files that had just been copied. * guix/store/deduplication.scm (copy-file/deduplicate): New procedure. * tests/store-deduplication.scm ("copy-file/deduplicate"): New test. * guix/build/store-copy.scm (populate-store): Add #:deduplicate? parameter and honor it. * tests/gexp.scm ("gexp->derivation, store copy"): Pass #:deduplicate? #f to 'populate-store'. * gnu/build/image.scm (initialize-root-partition): Pass #:deduplicate? to 'populate-store'. Pass #:deduplicate? #f to 'register-closure'. * gnu/build/vm.scm (root-partition-initializer): Likewise. * gnu/build/install.scm (populate-single-profile-directory): Pass #:deduplicate? #f to 'populate-store'. * gnu/build/linux-initrd.scm (build-initrd): Likewise. * guix/scripts/pack.scm (self-contained-tarball)[import-module?]: New procedure. [build]: Pass it as an argument to 'source-module-closure'. * guix/scripts/pack.scm (squashfs-image)[build]: Wrap in 'with-extensions'. * gnu/system/linux-initrd.scm (expression->initrd)[import-module?]: New procedure. [builder]: Pass it to 'source-module-closure'. * gnu/system/install.scm (cow-store-service-type)[import-module?]: New procedure. Pass it to 'source-module-closure'.master
parent
dea1ee1fd7
commit
6a060ff27f
|
@ -186,7 +186,8 @@ rest of the store when registering the closures. SYSTEM-DIRECTORY is the name
|
||||||
of the directory of the 'system' derivation. Pass WAL-MODE? to
|
of the directory of the 'system' derivation. Pass WAL-MODE? to
|
||||||
register-closure."
|
register-closure."
|
||||||
(populate-root-file-system system-directory root)
|
(populate-root-file-system system-directory root)
|
||||||
(populate-store references-graphs root)
|
(populate-store references-graphs root
|
||||||
|
#:deduplicate? deduplicate?)
|
||||||
|
|
||||||
;; Populate /dev.
|
;; Populate /dev.
|
||||||
(when make-device-nodes
|
(when make-device-nodes
|
||||||
|
@ -195,7 +196,7 @@ register-closure."
|
||||||
(when register-closures?
|
(when register-closures?
|
||||||
(for-each (lambda (closure)
|
(for-each (lambda (closure)
|
||||||
(register-closure root closure
|
(register-closure root closure
|
||||||
#:deduplicate? deduplicate?
|
#:deduplicate? #f
|
||||||
#:wal-mode? wal-mode?))
|
#:wal-mode? wal-mode?))
|
||||||
references-graphs))
|
references-graphs))
|
||||||
|
|
||||||
|
|
|
@ -214,7 +214,8 @@ This is used to create the self-contained tarballs with 'guix pack'."
|
||||||
(symlink old (scope new)))
|
(symlink old (scope new)))
|
||||||
|
|
||||||
;; Populate the store.
|
;; Populate the store.
|
||||||
(populate-store (list closure) directory)
|
(populate-store (list closure) directory
|
||||||
|
#:deduplicate? #f)
|
||||||
|
|
||||||
(when database
|
(when database
|
||||||
(install-database-and-gc-roots directory database profile
|
(install-database-and-gc-roots directory database profile
|
||||||
|
|
|
@ -127,7 +127,8 @@ REFERENCES-GRAPHS."
|
||||||
(mkdir "contents")
|
(mkdir "contents")
|
||||||
|
|
||||||
;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
|
;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
|
||||||
(populate-store references-graphs "contents")
|
(populate-store references-graphs "contents"
|
||||||
|
#:deduplicate? #f)
|
||||||
|
|
||||||
(with-directory-excursion "contents"
|
(with-directory-excursion "contents"
|
||||||
;; Make '/init'.
|
;; Make '/init'.
|
||||||
|
|
|
@ -395,7 +395,8 @@ system that is passed to 'populate-root-file-system'."
|
||||||
(when copy-closures?
|
(when copy-closures?
|
||||||
;; Populate the store.
|
;; Populate the store.
|
||||||
(populate-store (map (cut string-append "/xchg/" <>) closures)
|
(populate-store (map (cut string-append "/xchg/" <>) closures)
|
||||||
target))
|
target
|
||||||
|
#:deduplicate? deduplicate?))
|
||||||
|
|
||||||
;; Populate /dev.
|
;; Populate /dev.
|
||||||
(make-device-nodes target)
|
(make-device-nodes target)
|
||||||
|
@ -412,7 +413,7 @@ system that is passed to 'populate-root-file-system'."
|
||||||
(for-each (lambda (closure)
|
(for-each (lambda (closure)
|
||||||
(register-closure target
|
(register-closure target
|
||||||
(string-append "/xchg/" closure)
|
(string-append "/xchg/" closure)
|
||||||
#:deduplicate? deduplicate?))
|
#:deduplicate? #f))
|
||||||
closures)
|
closures)
|
||||||
(unless copy-closures?
|
(unless copy-closures?
|
||||||
(umount target-store)))
|
(umount target-store)))
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
|
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
|
||||||
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
|
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
|
||||||
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
|
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
|
||||||
|
@ -176,6 +176,13 @@ manual."
|
||||||
(shepherd-service-type
|
(shepherd-service-type
|
||||||
'cow-store
|
'cow-store
|
||||||
(lambda _
|
(lambda _
|
||||||
|
(define (import-module? module)
|
||||||
|
;; Since we don't use deduplication support in 'populate-store', don't
|
||||||
|
;; import (guix store deduplication) and its dependencies, which
|
||||||
|
;; includes Guile-Gcrypt.
|
||||||
|
(and (guix-module-name? module)
|
||||||
|
(not (equal? module '(guix store deduplication)))))
|
||||||
|
|
||||||
(shepherd-service
|
(shepherd-service
|
||||||
(requirement '(root-file-system user-processes))
|
(requirement '(root-file-system user-processes))
|
||||||
(provision '(cow-store))
|
(provision '(cow-store))
|
||||||
|
@ -190,7 +197,8 @@ the given target.")
|
||||||
,@%default-modules))
|
,@%default-modules))
|
||||||
(start
|
(start
|
||||||
(with-imported-modules (source-module-closure
|
(with-imported-modules (source-module-closure
|
||||||
'((gnu build install)))
|
'((gnu build install))
|
||||||
|
#:select? import-module?)
|
||||||
#~(case-lambda
|
#~(case-lambda
|
||||||
((target)
|
((target)
|
||||||
(mount-cow-store target #$%backing-directory)
|
(mount-cow-store target #$%backing-directory)
|
||||||
|
|
|
@ -76,12 +76,20 @@ the derivations referenced by EXP are automatically copied to the initrd."
|
||||||
(define init
|
(define init
|
||||||
(program-file "init" exp #:guile guile))
|
(program-file "init" exp #:guile guile))
|
||||||
|
|
||||||
|
(define (import-module? module)
|
||||||
|
;; Since we don't use deduplication support in 'populate-store', don't
|
||||||
|
;; import (guix store deduplication) and its dependencies, which includes
|
||||||
|
;; Guile-Gcrypt. That way we can run tests with '--bootstrap'.
|
||||||
|
(and (guix-module-name? module)
|
||||||
|
(not (equal? module '(guix store deduplication)))))
|
||||||
|
|
||||||
(define builder
|
(define builder
|
||||||
;; Do not use "guile-zlib" extension here, otherwise it would drag the
|
;; Do not use "guile-zlib" extension here, otherwise it would drag the
|
||||||
;; non-static "zlib" package to the initrd closure. It is not needed
|
;; non-static "zlib" package to the initrd closure. It is not needed
|
||||||
;; anyway because the modules are stored uncompressed within the initrd.
|
;; anyway because the modules are stored uncompressed within the initrd.
|
||||||
(with-imported-modules (source-module-closure
|
(with-imported-modules (source-module-closure
|
||||||
'((gnu build linux-initrd)))
|
'((gnu build linux-initrd))
|
||||||
|
#:select? import-module?)
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (gnu build linux-initrd))
|
(use-modules (gnu build linux-initrd))
|
||||||
|
|
||||||
|
|
|
@ -20,6 +20,7 @@
|
||||||
#:use-module ((guix build utils) #:hide (copy-recursively))
|
#:use-module ((guix build utils) #:hide (copy-recursively))
|
||||||
#:use-module (guix sets)
|
#:use-module (guix sets)
|
||||||
#:use-module (guix progress)
|
#:use-module (guix progress)
|
||||||
|
#:autoload (guix store deduplication) (copy-file/deduplicate)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
@ -242,10 +243,13 @@ permissions. Write verbose output to the LOG port."
|
||||||
lstat)))
|
lstat)))
|
||||||
|
|
||||||
(define* (populate-store reference-graphs target
|
(define* (populate-store reference-graphs target
|
||||||
#:key (log-port (current-error-port)))
|
#:key
|
||||||
|
(deduplicate? #t)
|
||||||
|
(log-port (current-error-port)))
|
||||||
"Populate the store under directory TARGET with the items specified in
|
"Populate the store under directory TARGET with the items specified in
|
||||||
REFERENCE-GRAPHS, a list of reference-graph files. Items copied to TARGET
|
REFERENCE-GRAPHS, a list of reference-graph files. Items copied to TARGET
|
||||||
maintain timestamps and permissions."
|
maintain timestamps and permissions. When DEDUPLICATE? is true, deduplicate
|
||||||
|
regular files as they are copied to TARGET."
|
||||||
(define store
|
(define store
|
||||||
(string-append target (%store-directory)))
|
(string-append target (%store-directory)))
|
||||||
|
|
||||||
|
@ -273,6 +277,11 @@ maintain timestamps and permissions."
|
||||||
(string-append target thing)
|
(string-append target thing)
|
||||||
#:keep-mtime? #t
|
#:keep-mtime? #t
|
||||||
#:keep-permissions? #t
|
#:keep-permissions? #t
|
||||||
|
#:copy-file
|
||||||
|
(if deduplicate?
|
||||||
|
(cut copy-file/deduplicate <> <>
|
||||||
|
#:store store)
|
||||||
|
copy-file)
|
||||||
#:log (%make-void-port "w"))
|
#:log (%make-void-port "w"))
|
||||||
(report))
|
(report))
|
||||||
things)))))
|
things)))))
|
||||||
|
|
|
@ -203,12 +203,19 @@ added to the pack."
|
||||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||||
(setlocale LC_ALL "en_US.utf8"))))
|
(setlocale LC_ALL "en_US.utf8"))))
|
||||||
|
|
||||||
|
(define (import-module? module)
|
||||||
|
;; Since we don't use deduplication support in 'populate-store', don't
|
||||||
|
;; import (guix store deduplication) and its dependencies, which includes
|
||||||
|
;; Guile-Gcrypt. That way we can run tests with '--bootstrap'.
|
||||||
|
(and (not-config? module)
|
||||||
|
(not (equal? '(guix store deduplication) module))))
|
||||||
|
|
||||||
(define build
|
(define build
|
||||||
(with-imported-modules (source-module-closure
|
(with-imported-modules (source-module-closure
|
||||||
`((guix build utils)
|
`((guix build utils)
|
||||||
(guix build union)
|
(guix build union)
|
||||||
(gnu build install))
|
(gnu build install))
|
||||||
#:select? not-config?)
|
#:select? import-module?)
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (guix build utils)
|
(use-modules (guix build utils)
|
||||||
((guix build union) #:select (relative-file-name))
|
((guix build union) #:select (relative-file-name))
|
||||||
|
@ -382,6 +389,7 @@ added to the pack."
|
||||||
`(("/bin" -> "bin") ,@symlinks)))
|
`(("/bin" -> "bin") ,@symlinks)))
|
||||||
|
|
||||||
(define build
|
(define build
|
||||||
|
(with-extensions (list guile-gcrypt)
|
||||||
(with-imported-modules (source-module-closure
|
(with-imported-modules (source-module-closure
|
||||||
'((guix build utils)
|
'((guix build utils)
|
||||||
(guix build store-copy)
|
(guix build store-copy)
|
||||||
|
@ -487,7 +495,7 @@ added to the pack."
|
||||||
"-p" "/.singularity.d/actions d 555 0 0"
|
"-p" "/.singularity.d/actions d 555 0 0"
|
||||||
|
|
||||||
,@(if entry-point
|
,@(if entry-point
|
||||||
`(;; This one if for Singularity 2.x.
|
`( ;; This one if for Singularity 2.x.
|
||||||
"-p"
|
"-p"
|
||||||
,(string-append
|
,(string-append
|
||||||
"/.singularity.d/actions/run s 777 0 0 "
|
"/.singularity.d/actions/run s 777 0 0 "
|
||||||
|
@ -513,7 +521,7 @@ added to the pack."
|
||||||
(when database
|
(when database
|
||||||
;; Initialize /var/guix.
|
;; Initialize /var/guix.
|
||||||
(install-database-and-gc-roots "var-etc" database #$profile)
|
(install-database-and-gc-roots "var-etc" database #$profile)
|
||||||
(mksquashfs `("var-etc" ,#$output))))))
|
(mksquashfs `("var-etc" ,#$output)))))))
|
||||||
|
|
||||||
(gexp->derivation (string-append name
|
(gexp->derivation (string-append name
|
||||||
(compressor-extension compressor)
|
(compressor-extension compressor)
|
||||||
|
|
|
@ -34,7 +34,8 @@
|
||||||
#:use-module (guix serialization)
|
#:use-module (guix serialization)
|
||||||
#:export (nar-sha256
|
#:export (nar-sha256
|
||||||
deduplicate
|
deduplicate
|
||||||
dump-file/deduplicate))
|
dump-file/deduplicate
|
||||||
|
copy-file/deduplicate))
|
||||||
|
|
||||||
;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
|
;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
|
||||||
;; 'port-position' throws to 'out-of-range' when the offset is great than or
|
;; 'port-position' throws to 'out-of-range' when the offset is great than or
|
||||||
|
@ -256,3 +257,16 @@ down the road."
|
||||||
(get-hash)))))
|
(get-hash)))))
|
||||||
|
|
||||||
(deduplicate file hash #:store store))
|
(deduplicate file hash #:store store))
|
||||||
|
|
||||||
|
(define* (copy-file/deduplicate source target
|
||||||
|
#:key (store (%store-directory)))
|
||||||
|
"Like 'copy-file', but additionally deduplicate TARGET in STORE."
|
||||||
|
(call-with-input-file source
|
||||||
|
(lambda (input)
|
||||||
|
(let ((stat (stat input)))
|
||||||
|
(dump-file/deduplicate target input (stat:size stat)
|
||||||
|
(if (zero? (logand (stat:mode stat)
|
||||||
|
#o100))
|
||||||
|
'regular
|
||||||
|
'executable)
|
||||||
|
#:store store)))))
|
||||||
|
|
|
@ -736,7 +736,8 @@
|
||||||
(zero? (logand #o222 (stat:mode st)))))))
|
(zero? (logand #o222 (stat:mode st)))))))
|
||||||
|
|
||||||
(mkdir #$output)
|
(mkdir #$output)
|
||||||
(populate-store '("graph") #$output)
|
(populate-store '("graph") #$output
|
||||||
|
#:deduplicate? #f)
|
||||||
|
|
||||||
;; Check whether 'populate-store' canonicalizes
|
;; Check whether 'populate-store' canonicalizes
|
||||||
;; permissions and timestamps.
|
;; permissions and timestamps.
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (ice-9 binary-ports)
|
#:use-module (ice-9 binary-ports)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-64))
|
#:use-module (srfi srfi-64))
|
||||||
|
|
||||||
(test-begin "store-deduplication")
|
(test-begin "store-deduplication")
|
||||||
|
@ -106,4 +107,19 @@
|
||||||
(cons (apply = (map (compose stat:ino stat) identical))
|
(cons (apply = (map (compose stat:ino stat) identical))
|
||||||
(map (compose stat:nlink stat) identical))))))
|
(map (compose stat:nlink stat) identical))))))
|
||||||
|
|
||||||
|
(test-assert "copy-file/deduplicate"
|
||||||
|
(call-with-temporary-directory
|
||||||
|
(lambda (store)
|
||||||
|
(let ((source (search-path %load-path "gnu/packages/emacs-xyz.scm")))
|
||||||
|
(for-each (lambda (target)
|
||||||
|
(copy-file/deduplicate source
|
||||||
|
(string-append store target)
|
||||||
|
#:store store))
|
||||||
|
'("/a" "/b" "/c"))
|
||||||
|
(and (directory-exists? (string-append store "/.links"))
|
||||||
|
(file=? source (string-append store "/a"))
|
||||||
|
(apply = (map (compose stat:ino stat
|
||||||
|
(cut string-append store <>))
|
||||||
|
'("/a" "/b" "/c"))))))))
|
||||||
|
|
||||||
(test-end "store-deduplication")
|
(test-end "store-deduplication")
|
||||||
|
|
Reference in New Issue