* bug#44760: [PATCH 01/15] serialization: 'fold-archive' notifies about directory processing completion.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 02/15] serialization: 'restore-file' sets canonical timestamp and permissions Ludovic Courtès
` (8 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
* guix/serialization.scm (fold-archive): Call PROC with a
'directory-complete tag when done with a directory.
(restore-file): Handle it.
* guix/scripts/archive.scm (list-contents): Likewise.
* guix/scripts/challenge.scm (archive-contents): Likewise.
* tests/nar.scm ("write-file-tree + fold-archive"): Adjust accordingly.
---
guix/scripts/archive.scm | 2 ++
guix/scripts/challenge.scm | 1 +
guix/serialization.scm | 5 ++++-
tests/nar.scm | 6 ++++--
4 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index c04baf9784..1f73fff711 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -347,6 +347,8 @@ output port."
(match type
('directory
(format #t "D ~a~%" file))
+ ('directory-complete
+ #t)
('symlink
(format #t "S ~a -> ~a~%" file content))
((or 'regular 'executable)
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 39bd2c1c0f..d0a456ac1d 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -210,6 +210,7 @@ taken since we do not import the archives."
(cons `(,file ,type ,(port-sha256* port size))
result))))
('directory result)
+ ('directory-complete result)
('symlink
(cons `(,file ,type ,contents) result))))
'()
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 836ad06caf..cc56134ef4 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -444,7 +444,8 @@ depends on TYPE."
(file file)
(token x))))))
(loop (read-string port) result)))))
- (")" result) ;done with DIR
+ (")" ;done with DIR
+ (proc file 'directory-complete #f result))
(x
(raise
(condition
@@ -463,6 +464,8 @@ Restore it as FILE."
(match type
('directory
(mkdir file))
+ ('directory-complete
+ #t)
('symlink
(symlink content file))
((or 'regular 'executable)
diff --git a/tests/nar.scm b/tests/nar.scm
index aeff3d3330..b542ebd47c 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -218,8 +218,10 @@
'(("R" directory #f)
("R/dir" directory #f)
("R/dir/exe" executable "1234")
+ ("R/dir" directory-complete #f)
("R/foo" regular "abcdefg")
- ("R/lnk" symlink "foo"))
+ ("R/lnk" symlink "foo")
+ ("R" directory-complete #f))
(let ()
(define-values (port get-bytevector)
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 02/15] serialization: 'restore-file' sets canonical timestamp and permissions.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 01/15] serialization: 'fold-archive' notifies about directory processing completion Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 03/15] nar: Deduplicate files right as they are restored Ludovic Courtès
` (7 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
* guix/serialization.scm (restore-file): Set the permissions and mtime
of FILE.
* guix/nar.scm (finalize-store-file): Pass #:reset-timestamps? #f to
'register-items'.
* tests/nar.scm (rm-rf): Add 'chmod' calls to ensure files are writable.
("write-file + restore-file with symlinks"): Ensure every file in OUTPUT
passes 'canonical-file?'.
* tests/guix-archive.sh: Run "chmod -R +w" before "rm -rf".
---
guix/nar.scm | 8 +++++---
guix/serialization.scm | 14 +++++++++-----
tests/guix-archive.sh | 4 ++--
tests/nar.scm | 12 ++++++++++--
4 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/guix/nar.scm b/guix/nar.scm
index a23af2e5de..edfcc9aab5 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -114,10 +114,12 @@ held."
;; Install the new TARGET.
(rename-file source target)
- ;; Register TARGET. As a side effect, it resets the timestamps of all
- ;; its files, recursively, and runs a deduplication pass.
+ ;; Register TARGET. As a side effect, run a deduplication pass.
+ ;; Timestamps and permissions are already correct thanks to
+ ;; 'restore-file'.
(register-items db
- (list (store-info target deriver references))))
+ (list (store-info target deriver references))
+ #:reset-timestamps? #f))
(when lock?
(delete-file (string-append target ".lock"))
diff --git a/guix/serialization.scm b/guix/serialization.scm
index cc56134ef4..677ca60b66 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -459,23 +459,27 @@ depends on TYPE."
(define (restore-file port file)
"Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE."
+Restore it as FILE with canonical permissions and timestamps."
(fold-archive (lambda (file type content result)
(match type
('directory
(mkdir file))
('directory-complete
- #t)
+ (chmod file #o555)
+ (utime file 1 1 0 0))
('symlink
- (symlink content file))
+ (symlink content file)
+ (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
((or 'regular 'executable)
(match content
((input . size)
(call-with-output-file file
(lambda (output)
(dump input output size)
- (when (eq? type 'executable)
- (chmod output #o755)))))))))
+ (chmod output (if (eq? type 'executable)
+ #o555
+ #o444))))
+ (utime file 1 1 0 0))))))
#t
port
file))
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index e796c62f9a..00b87ff0ac 100644
--- a/tests/guix-archive.sh
+++ b/tests/guix-archive.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -28,7 +28,7 @@ tmpdir="t-archive-dir-$$"
rm -f "$archive" "$archive_alt"
rm -rf "$tmpdir"
-trap 'rm -f "$archive" "$archive_alt"; rm -rf "$tmpdir"' EXIT
+trap 'rm -f "$archive" "$archive_alt"; chmod -R +w "$tmpdir"; rm -rf "$tmpdir"' EXIT
guix archive --export guile-bootstrap > "$archive"
guix archive --export guile-bootstrap:out > "$archive_alt"
diff --git a/tests/nar.scm b/tests/nar.scm
index b542ebd47c..59616659c8 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -136,8 +136,11 @@
(define (rm-rf dir)
(file-system-fold (const #t) ; enter?
(lambda (file stat result) ; leaf
+ (unless (eq? 'symlink (stat:type stat))
+ (chmod file #o644))
(delete-file file))
- (const #t) ; down
+ (lambda (dir stat result) ; down
+ (chmod dir #o755))
(lambda (dir stat result) ; up
(rmdir dir))
(const #t) ; skip
@@ -363,7 +366,12 @@
(cut write-file input <>))
(call-with-input-file nar
(cut restore-file <> output))
- (file-tree-equal? input output))
+
+ (and (file-tree-equal? input output)
+ (every (lambda (file)
+ (canonical-file?
+ (string-append output "/" file)))
+ '("root" "root/reg" "root/exe"))))
(lambda ()
(false-if-exception (delete-file nar))
(false-if-exception (rm-rf output)))))))
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 03/15] nar: Deduplicate files right as they are restored.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 01/15] serialization: 'fold-archive' notifies about directory processing completion Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 02/15] serialization: 'restore-file' sets canonical timestamp and permissions Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 04/15] store-copy: 'populate-store' resets timestamps Ludovic Courtès
` (6 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
This avoids having to traverse and re-read the files that we have just
restored, thereby reducing I/O.
* guix/serialization.scm (dump-file): New procedure.
(restore-file): Add #:dump-file parameter and honor it.
* guix/store/deduplication.scm (tee, dump-file/deduplicate): New
procedures.
* guix/nar.scm (restore-one-item): Pass #:dump-file to 'restore-file'.
(finalize-store-file): Pass #:deduplicate? #f to 'register-items'.
* tests/nar.scm <top level>: Call 'setenv' to set "NIX_STORE".
---
guix/nar.scm | 12 ++++----
guix/serialization.scm | 27 ++++++++++++-----
guix/store/deduplication.scm | 57 +++++++++++++++++++++++++++++++++++-
tests/nar.scm | 3 ++
4 files changed, 85 insertions(+), 14 deletions(-)
diff --git a/guix/nar.scm b/guix/nar.scm
index edfcc9aab5..ba035ca6dc 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -27,6 +27,7 @@
;; (guix store) since this is "daemon-side" code.
#:use-module (guix store)
#:use-module (guix store database)
+ #:use-module ((guix store deduplication) #:select (dump-file/deduplicate))
#:use-module ((guix build store-copy) #:select (store-info))
#:use-module (guix i18n)
@@ -114,12 +115,12 @@ held."
;; Install the new TARGET.
(rename-file source target)
- ;; Register TARGET. As a side effect, run a deduplication pass.
- ;; Timestamps and permissions are already correct thanks to
- ;; 'restore-file'.
+ ;; Register TARGET. The 'restore-file' call took care of
+ ;; deduplication, timestamps, and permissions.
(register-items db
(list (store-info target deriver references))
- #:reset-timestamps? #f))
+ #:reset-timestamps? #f
+ #:deduplicate? #f))
(when lock?
(delete-file (string-append target ".lock"))
@@ -212,7 +213,8 @@ s-expression"))
(let-values (((port get-hash)
(open-sha256-input-port port)))
(with-temporary-store-file temp
- (restore-file port temp)
+ (restore-file port temp
+ #:dump-file dump-file/deduplicate)
(let ((magic (read-int port)))
(unless (= magic %export-magic)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 677ca60b66..9e2dce8bb0 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -457,9 +457,22 @@ depends on TYPE."
(&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x)))))))))
-(define (restore-file port file)
+(define (dump-file file input size type)
+ "Dump SIZE bytes from INPUT to FILE."
+ (call-with-output-file file
+ (lambda (output)
+ (dump input output size))))
+
+(define* (restore-file port file
+ #:key (dump-file dump-file))
"Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE with canonical permissions and timestamps."
+Restore it as FILE with canonical permissions and timestamps. To write a
+regular or executable file, call:
+
+ (DUMP-FILE FILE INPUT SIZE TYPE)
+
+The default is to dump SIZE bytes from INPUT to FILE, but callers can provide
+a custom procedure, for instance to deduplicate FILE on the fly."
(fold-archive (lambda (file type content result)
(match type
('directory
@@ -473,12 +486,10 @@ Restore it as FILE with canonical permissions and timestamps."
((or 'regular 'executable)
(match content
((input . size)
- (call-with-output-file file
- (lambda (output)
- (dump input output size)
- (chmod output (if (eq? type 'executable)
- #o555
- #o444))))
+ (dump-file file input size type)
+ (chmod file (if (eq? type 'executable)
+ #o555
+ #o444))
(utime file 1 1 0 0))))))
#t
port
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 0655ceb890..b4d37d4525 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -26,12 +26,15 @@
#:use-module (guix build syscalls)
#:use-module (guix base32)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (rnrs io ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (guix serialization)
#:export (nar-sha256
- deduplicate))
+ deduplicate
+ dump-file/deduplicate))
;; 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
@@ -201,3 +204,55 @@ under STORE."
;; that's OK: we just can't deduplicate it more.
#f)
(else (apply throw args)))))))))))
+
+(define (tee input len output)
+ "Return a port that reads up to LEN bytes from INPUT and writes them to
+OUTPUT as it goes."
+ (define bytes-read 0)
+
+ (define (fail)
+ ;; Reached EOF before we had read LEN bytes from INPUT.
+ (raise (condition
+ (&nar-error (port input)
+ (file (port-filename output))))))
+
+ (define (read! bv start count)
+ ;; Read at most LEN bytes in total.
+ (let ((count (min count (- len bytes-read))))
+ (let loop ((ret (get-bytevector-n! input bv start count)))
+ (cond ((eof-object? ret)
+ (if (= bytes-read len)
+ 0 ; EOF
+ (fail)))
+ ((and (zero? ret) (> count 0))
+ ;; Do not return zero since zero means EOF, so try again.
+ (loop (get-bytevector-n! input bv start count)))
+ (else
+ (put-bytevector output bv start ret)
+ (set! bytes-read (+ bytes-read ret))
+ ret)))))
+
+ (make-custom-binary-input-port "tee input port" read! #f #f #f))
+
+(define* (dump-file/deduplicate file input size type
+ #:key (store (%store-directory)))
+ "Write SIZE bytes read from INPUT to FILE. TYPE is a symbol, either
+'regular or 'executable.
+
+This procedure is suitable as a #:dump-file argument to 'restore-file'. When
+used that way, it deduplicates files on the fly as they are restored, thereby
+removing the need to a deduplication pass that would re-read all the files
+down the road."
+ (define hash
+ (call-with-output-file file
+ (lambda (output)
+ (let-values (((hash-port get-hash)
+ (open-hash-port (hash-algorithm sha256))))
+ (write-file-tree file hash-port
+ #:file-type+size (lambda (_) (values type size))
+ #:file-port
+ (const (tee input size output)))
+ (close-port hash-port)
+ (get-hash)))))
+
+ (deduplicate file hash #:store store))
diff --git a/tests/nar.scm b/tests/nar.scm
index 59616659c8..ba4881caaa 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -452,6 +452,9 @@
(false-if-exception (rm-rf %test-dir))
(setlocale LC_ALL locale)))))
+;; XXX: Tell the 'deduplicate' procedure what store we're actually using.
+(setenv "NIX_STORE" (%store-prefix))
+
(test-assert "restore-file-set (signed, valid)"
(with-store store
(let* ((texts (unfold (cut >= <> 10)
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 04/15] store-copy: 'populate-store' resets timestamps.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (2 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 03/15] nar: Deduplicate files right as they are restored Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 05/15] image: 'register-closure' assumes already-reset timestamps Ludovic Courtès
` (5 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
Until now, 'populate-store' would reset permissions but not timestamps,
so callers would resort to going through an extra directory traversal to
reset timestamps.
* guix/build/store-copy.scm (reset-permissions): Remove.
(copy-recursively): New procedure.
(populate-store): Pass #:keep-permissions? to 'copy-recursively'.
Remove call to 'reset-permissions'.
* tests/gexp.scm ("gexp->derivation, store copy"): In BUILD-DRV, check
whether 'populate-store' canonicalizes permissions and timestamps.
* gnu/build/image.scm (initialize-root-partition): Pass #:reset-timestamps? #f
to 'register-closure'.
* gnu/build/vm.scm (root-partition-initializer): Likewise.
---
gnu/build/image.scm | 5 +-
gnu/build/vm.scm | 2 +-
guix/build/store-copy.scm | 103 +++++++++++++++++++++++++++-----------
tests/gexp.scm | 19 ++++++-
4 files changed, 95 insertions(+), 34 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 640a784204..2857362914 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -196,9 +196,8 @@ register-closure."
(when register-closures?
(for-each (lambda (closure)
- (register-closure root
- closure
- #:reset-timestamps? #t
+ (register-closure root closure
+ #:reset-timestamps? #f
#:deduplicate? deduplicate?
#:wal-mode? wal-mode?))
references-graphs))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 287d099f79..30feaf800f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -414,7 +414,7 @@ system that is passed to 'populate-root-file-system'."
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)
- #:reset-timestamps? copy-closures?
+ #:reset-timestamps? #f
#:deduplicate? deduplicate?))
closures)
(unless copy-closures?
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index ad551bca98..95dcb8e114 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build store-copy)
- #:use-module (guix build utils)
+ #:use-module ((guix build utils) #:hide (copy-recursively))
#:use-module (guix sets)
#:use-module (guix progress)
#:use-module (srfi srfi-1)
@@ -169,32 +169,83 @@ REFERENCE-GRAPHS, a list of reference-graph files."
(reduce + 0 (map file-size items)))
-(define (reset-permissions file)
- "Reset the permissions on FILE and its sub-directories so that they are all
-read-only."
- ;; XXX: This procedure exists just to work around the inability of
- ;; 'copy-recursively' to preserve permissions.
- (file-system-fold (const #t) ;enter?
- (lambda (file stat _) ;leaf
- (unless (eq? 'symlink (stat:type stat))
- (chmod file
- (if (zero? (logand (stat:mode stat)
- #o100))
- #o444
- #o555))))
- (const #t) ;down
- (lambda (directory stat _) ;up
- (chmod directory #o555))
- (const #f) ;skip
- (const #f) ;error
+;; TODO: Remove when the one in (guix build utils) has #:keep-permissions?,
+;; the fix for <https://bugs.gnu.org/44741>, and when #:keep-mtime? works for
+;; symlinks.
+(define* (copy-recursively source destination
+ #:key
+ (log (current-output-port))
+ (follow-symlinks? #f)
+ (copy-file copy-file)
+ keep-mtime? keep-permissions?)
+ "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS?
+is true; otherwise, just preserve them. Call COPY-FILE to copy regular files.
+When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on
+those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file
+permissions. Write verbose output to the LOG port."
+ (define AT_SYMLINK_NOFOLLOW
+ ;; Guile 2.0 did not define this constant, hence this hack.
+ (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW)))
+ (if variable
+ (variable-ref variable)
+ 256))) ;for GNU/Linux
+
+ (define (set-file-time file stat)
+ (utime file
+ (stat:atime stat)
+ (stat:mtime stat)
+ (stat:atimensec stat)
+ (stat:mtimensec stat)
+ AT_SYMLINK_NOFOLLOW))
+
+ (define strip-source
+ (let ((len (string-length source)))
+ (lambda (file)
+ (substring file len))))
+
+ (file-system-fold (const #t) ; enter?
+ (lambda (file stat result) ; leaf
+ (let ((dest (string-append destination
+ (strip-source file))))
+ (format log "`~a' -> `~a'~%" file dest)
+ (case (stat:type stat)
+ ((symlink)
+ (let ((target (readlink file)))
+ (symlink target dest)))
+ (else
+ (copy-file file dest)
+ (when keep-permissions?
+ (chmod dest (stat:perms stat)))))
+ (when keep-mtime?
+ (set-file-time dest stat))))
+ (lambda (dir stat result) ; down
+ (let ((target (string-append destination
+ (strip-source dir))))
+ (mkdir-p target)))
+ (lambda (dir stat result) ; up
+ (let ((target (string-append destination
+ (strip-source dir))))
+ (when keep-mtime?
+ (set-file-time target stat))
+ (when keep-permissions?
+ (chmod target (stat:perms stat)))))
+ (const #t) ; skip
+ (lambda (file stat errno result)
+ (format (current-error-port) "i/o error: ~a: ~a~%"
+ file (strerror errno))
+ #f)
#t
- file
- lstat))
+ source
+
+ (if follow-symlinks?
+ stat
+ lstat)))
(define* (populate-store reference-graphs target
#:key (log-port (current-error-port)))
"Populate the store under directory TARGET with the items specified in
-REFERENCE-GRAPHS, a list of reference-graph files."
+REFERENCE-GRAPHS, a list of reference-graph files. Items copied to TARGET
+maintain timestamps and permissions."
(define store
(string-append target (%store-directory)))
@@ -221,12 +272,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
(copy-recursively thing
(string-append target thing)
#:keep-mtime? #t
+ #:keep-permissions? #t
#:log (%make-void-port "w"))
-
- ;; XXX: Since 'copy-recursively' doesn't allow us to
- ;; preserve permissions, we have to traverse TARGET to
- ;; make sure everything is read-only.
- (reset-permissions (string-append target thing))
(report))
things)))))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 686334af61..a0e55178fa 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -723,10 +723,25 @@
(lambda (port)
(display "This is the second one." port))))))
(build-drv #~(begin
- (use-modules (guix build store-copy))
+ (use-modules (guix build store-copy)
+ (guix build utils)
+ (srfi srfi-1))
+
+ (define (canonical-file? file)
+ ;; Copied from (guix tests).
+ (let ((st (lstat file)))
+ (or (not (string-prefix? (%store-directory) file))
+ (eq? 'symlink (stat:type st))
+ (and (= 1 (stat:mtime st))
+ (zero? (logand #o222 (stat:mode st)))))))
(mkdir #$output)
- (populate-store '("graph") #$output))))
+ (populate-store '("graph") #$output)
+
+ ;; Check whether 'populate-store' canonicalizes
+ ;; permissions and timestamps.
+ (unless (every canonical-file? (find-files #$output))
+ (error "not canonical!" #$output)))))
(mlet* %store-monad ((one (gexp->derivation "one" build-one))
(two (gexp->derivation "two" (build-two one)))
(drv (gexp->derivation "store-copy" build-drv
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 05/15] image: 'register-closure' assumes already-reset timestamps.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (3 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 04/15] store-copy: 'populate-store' resets timestamps Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 06/15] database: Remove #:reset-timestamps? from 'register-items' Ludovic Courtès
` (4 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
* gnu/build/image.scm (register-closure): Remove #:reset-timestamps?
parameter. Pass #:reset-timestamps? #f to 'register-items'.
(initialize-root-partition): Adjust accordingly.
* gnu/build/vm.scm (register-closure, root-partition-initializer):
Likewise.
---
gnu/build/image.scm | 8 +++-----
gnu/build/vm.scm | 8 +++-----
2 files changed, 6 insertions(+), 10 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 2857362914..4f80a1964f 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -140,13 +140,12 @@ given CONFIG file."
(define* (register-closure prefix closure
#:key
- (deduplicate? #t) (reset-timestamps? #t)
+ (deduplicate? #t)
(schema (sql-schema))
(wal-mode? #t))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
+produced by #:references-graphs. As a side effect, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX. Pass WAL-MODE?
to call-with-database."
(let ((items (call-with-input-file closure read-reference-graph)))
@@ -156,7 +155,7 @@ to call-with-database."
(register-items db items
#:prefix prefix
#:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
+ #:reset-timestamps? #f
#:registration-time %epoch)))))
(define* (initialize-efi-partition root
@@ -197,7 +196,6 @@ register-closure."
(when register-closures?
(for-each (lambda (closure)
(register-closure root closure
- #:reset-timestamps? #f
#:deduplicate? deduplicate?
#:wal-mode? wal-mode?))
references-graphs))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 30feaf800f..f700e08b25 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -215,12 +215,11 @@ the #:references-graphs parameter of 'derivation'."
(define* (register-closure prefix closure
#:key
- (deduplicate? #t) (reset-timestamps? #t)
+ (deduplicate? #t)
(schema (sql-schema)))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
+produced by #:references-graphs. As a side effect, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
(parameterize ((sql-schema schema))
@@ -228,7 +227,7 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
(register-items db items
#:prefix prefix
#:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
+ #:reset-timestamps? #f
#:registration-time %epoch)))))
\f
@@ -414,7 +413,6 @@ system that is passed to 'populate-root-file-system'."
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)
- #:reset-timestamps? #f
#:deduplicate? deduplicate?))
closures)
(unless copy-closures?
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 06/15] database: Remove #:reset-timestamps? from 'register-items'.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (4 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 05/15] image: 'register-closure' assumes already-reset timestamps Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 07/15] store-copy: 'populate-store' can optionally deduplicate files Ludovic Courtès
` (3 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
The assumption now is that the caller took care of resetting timestamps
and permissions.
* guix/store/database.scm (register-items): Remove #:reset-timestamps?
parameter and the call to 'reset-timestamps'.
(register-path): Adjust accordingly and add call to 'reset-timestamps'.
* gnu/build/image.scm (register-closure): Remove #:reset-timestamps?
parameter to 'register-items'.
* gnu/build/vm.scm (register-closure): Likewise.
* guix/nar.scm (finalize-store-file): Adjust accordingly.
* guix/scripts/pack.scm (store-database)[build]: Likewise.
---
gnu/build/image.scm | 1 -
gnu/build/vm.scm | 1 -
guix/nar.scm | 1 -
guix/scripts/pack.scm | 1 -
guix/store/database.scm | 13 ++++++++-----
5 files changed, 8 insertions(+), 9 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 4f80a1964f..0deea10a9d 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -155,7 +155,6 @@ to call-with-database."
(register-items db items
#:prefix prefix
#:deduplicate? deduplicate?
- #:reset-timestamps? #f
#:registration-time %epoch)))))
(define* (initialize-efi-partition root
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index f700e08b25..abb0317faf 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -227,7 +227,6 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
(register-items db items
#:prefix prefix
#:deduplicate? deduplicate?
- #:reset-timestamps? #f
#:registration-time %epoch)))))
\f
diff --git a/guix/nar.scm b/guix/nar.scm
index ba035ca6dc..947b393d84 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -119,7 +119,6 @@ held."
;; deduplication, timestamps, and permissions.
(register-items db
(list (store-info target deriver references))
- #:reset-timestamps? #f
#:deduplicate? #f))
(when lock?
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ba9a6dc1b2..1612ec8f04 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -168,7 +168,6 @@ dependencies are registered."
(with-database db-file db
(register-items db items
#:deduplicate? #f
- #:reset-timestamps? #f
#:registration-time %epoch)))))))
(computed-file "store-database" build
diff --git a/guix/store/database.scm b/guix/store/database.scm
index b36b127630..0ed66a6e2c 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -392,7 +392,8 @@ references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
given, it must be the name of the directory containing the new store to
initialize; if STATE-DIRECTORY is given, it must be a string containing the
absolute file name to the state directory of the store being initialized.
-Return #t on success.
+Return #t on success. As a side effect, reset timestamps on PATH, unless
+RESET-TIMESTAMPS? is false.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook.
@@ -403,12 +404,17 @@ by adding it as a temp-root."
(store-database-file #:prefix prefix
#:state-directory state-directory))
+ (define real-file-name
+ (string-append (or prefix "") path))
+
+ (when reset-timestamps?
+ (reset-timestamps real-file-name))
+
(parameterize ((sql-schema schema))
(with-database db-file db
(register-items db (list (store-info path deriver references))
#:prefix prefix
#:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
#:log-port (%make-void-port "w")))))
(define %epoch
@@ -418,7 +424,6 @@ by adding it as a temp-root."
(define* (register-items db items
#:key prefix
(deduplicate? #t)
- (reset-timestamps? #t)
registration-time
(log-port (current-error-port)))
"Register all of ITEMS, a list of <store-info> records as returned by
@@ -452,8 +457,6 @@ typically by adding them as temp-roots."
;; significant differences when 'register-closures' is called
;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
(unless (path-id db to-register)
- (when reset-timestamps?
- (reset-timestamps real-file-name))
(let-values (((hash nar-size) (nar-sha256 real-file-name)))
(call-with-retrying-transaction db
(lambda ()
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 07/15] store-copy: 'populate-store' can optionally deduplicate files.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (5 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 06/15] database: Remove #:reset-timestamps? from 'register-items' Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 08/15] image: 'register-closure' leaves it up to the caller to deduplicate Ludovic Courtès
` (2 subsequent siblings)
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
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'.
---
gnu/build/image.scm | 5 +-
gnu/build/install.scm | 3 +-
gnu/build/linux-initrd.scm | 3 +-
gnu/build/vm.scm | 5 +-
gnu/system/install.scm | 12 +-
gnu/system/linux-initrd.scm | 10 +-
guix/build/store-copy.scm | 13 +-
guix/scripts/pack.scm | 274 +++++++++++++++++-----------------
guix/store/deduplication.scm | 16 +-
tests/gexp.scm | 3 +-
tests/store-deduplication.scm | 18 ++-
11 files changed, 215 insertions(+), 147 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 0deea10a9d..8f50f27f78 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -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
register-closure."
(populate-root-file-system system-directory root)
- (populate-store references-graphs root)
+ (populate-store references-graphs root
+ #:deduplicate? deduplicate?)
;; Populate /dev.
(when make-device-nodes
@@ -195,7 +196,7 @@ register-closure."
(when register-closures?
(for-each (lambda (closure)
(register-closure root closure
- #:deduplicate? deduplicate?
+ #:deduplicate? #f
#:wal-mode? wal-mode?))
references-graphs))
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 63995e1d09..f5c8407b89 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -214,7 +214,8 @@ This is used to create the self-contained tarballs with 'guix pack'."
(symlink old (scope new)))
;; Populate the store.
- (populate-store (list closure) directory)
+ (populate-store (list closure) directory
+ #:deduplicate? #f)
(when database
(install-database-and-gc-roots directory database profile
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index 99796adba6..bb2ed0db0c 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -127,7 +127,8 @@ REFERENCES-GRAPHS."
(mkdir "contents")
;; 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"
;; Make '/init'.
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index abb0317faf..03be5697b7 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -395,7 +395,8 @@ system that is passed to 'populate-root-file-system'."
(when copy-closures?
;; Populate the store.
(populate-store (map (cut string-append "/xchg/" <>) closures)
- target))
+ target
+ #:deduplicate? deduplicate?))
;; Populate /dev.
(make-device-nodes target)
@@ -412,7 +413,7 @@ system that is passed to 'populate-root-file-system'."
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)
- #:deduplicate? deduplicate?))
+ #:deduplicate? #f))
closures)
(unless copy-closures?
(umount target-store)))
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7701297411..06f8043bb7 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -1,5 +1,5 @@
;;; 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 © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
@@ -175,6 +175,13 @@ manual."
(shepherd-service-type
'cow-store
(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
(requirement '(root-file-system user-processes))
(provision '(cow-store))
@@ -189,7 +196,8 @@ the given target.")
,@%default-modules))
(start
(with-imported-modules (source-module-closure
- '((gnu build install)))
+ '((gnu build install))
+ #:select? import-module?)
#~(case-lambda
((target)
(mount-cow-store target #$%backing-directory)
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 4fb1d863c9..c6ba9bb560 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -76,12 +76,20 @@ the derivations referenced by EXP are automatically copied to the initrd."
(define init
(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
;; Do not use "guile-zlib" extension here, otherwise it would drag the
;; non-static "zlib" package to the initrd closure. It is not needed
;; anyway because the modules are stored uncompressed within the initrd.
(with-imported-modules (source-module-closure
- '((gnu build linux-initrd)))
+ '((gnu build linux-initrd))
+ #:select? import-module?)
#~(begin
(use-modules (gnu build linux-initrd))
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 95dcb8e114..7f0672cd9d 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -20,6 +20,7 @@
#:use-module ((guix build utils) #:hide (copy-recursively))
#:use-module (guix sets)
#:use-module (guix progress)
+ #:autoload (guix store deduplication) (copy-file/deduplicate)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
@@ -242,10 +243,13 @@ permissions. Write verbose output to the LOG port."
lstat)))
(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
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
(string-append target (%store-directory)))
@@ -273,6 +277,11 @@ maintain timestamps and permissions."
(string-append target thing)
#:keep-mtime? #t
#:keep-permissions? #t
+ #:copy-file
+ (if deduplicate?
+ (cut copy-file/deduplicate <> <>
+ #:store store)
+ copy-file)
#:log (%make-void-port "w"))
(report))
things)))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1612ec8f04..440c4b0903 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -203,12 +203,19 @@ added to the pack."
#+(file-append glibc-utf8-locales "/lib/locale"))
(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
(with-imported-modules (source-module-closure
`((guix build utils)
(guix build union)
(gnu build install))
- #:select? not-config?)
+ #:select? import-module?)
#~(begin
(use-modules (guix build utils)
((guix build union) #:select (relative-file-name))
@@ -382,138 +389,139 @@ added to the pack."
`(("/bin" -> "bin") ,@symlinks)))
(define build
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (guix build store-copy)
- (guix build union)
- (gnu build install))
- #:select? not-config?)
- #~(begin
- (use-modules (guix build utils)
- (guix build store-copy)
- ((guix build union) #:select (relative-file-name))
- (gnu build install)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match))
-
- (define database #+database)
- (define entry-point #$entry-point)
-
- (define (mksquashfs args)
- (apply invoke "mksquashfs"
- `(,@args
-
- ;; Do not create a "recovery file" when appending to the
- ;; file system since it's useless in this case.
- "-no-recovery"
-
- ;; Do not attempt to store extended attributes.
- ;; See <https://bugs.gnu.org/40043>.
- "-no-xattrs"
-
- ;; Set file times and the file system creation time to
- ;; one second after the Epoch.
- "-all-time" "1" "-mkfs-time" "1"
-
- ;; Reset all UIDs and GIDs.
- "-force-uid" "0" "-force-gid" "0")))
-
- (setenv "PATH" #+(file-append archiver "/bin"))
-
- ;; We need an empty file in order to have a valid file argument when
- ;; we reparent the root file system. Read on for why that's
- ;; necessary.
- (with-output-to-file ".empty" (lambda () (display "")))
-
- ;; Create the squashfs image in several steps.
- ;; Add all store items. Unfortunately mksquashfs throws away all
- ;; ancestor directories and only keeps the basename. We fix this
- ;; in the following invocations of mksquashfs.
- (mksquashfs `(,@(map store-info-item
- (call-with-input-file "profile"
- read-reference-graph))
- #$environment
- ,#$output
-
- ;; Do not perform duplicate checking because we
- ;; don't have any dupes.
- "-no-duplicates"
- "-comp"
- ,#+(compressor-name compressor)))
-
- ;; Here we reparent the store items. For each sub-directory of
- ;; the store prefix we need one invocation of "mksquashfs".
- (for-each (lambda (dir)
- (mksquashfs `(".empty"
- ,#$output
- "-root-becomes" ,dir)))
- (reverse (string-tokenize (%store-directory)
- (char-set-complement (char-set #\/)))))
-
- ;; Add symlinks and mount points.
- (mksquashfs
- `(".empty"
- ,#$output
- ;; Create SYMLINKS via pseudo file definitions.
- ,@(append-map
- (match-lambda
- ((source '-> target)
- ;; Create relative symlinks to work around a bug in
- ;; Singularity 2.x:
- ;; https://bugs.gnu.org/34913
- ;; https://github.com/sylabs/singularity/issues/1487
- (let ((target (string-append #$profile "/" target)))
- (list "-p"
- (string-join
- ;; name s mode uid gid symlink
- (list source
- "s" "777" "0" "0"
- (relative-file-name (dirname source)
- target)))))))
- '#$symlinks*)
-
- "-p" "/.singularity.d d 555 0 0"
-
- ;; Create the environment file.
- "-p" "/.singularity.d/env d 555 0 0"
- "-p" ,(string-append
- "/.singularity.d/env/90-environment.sh s 777 0 0 "
- (relative-file-name "/.singularity.d/env"
- #$environment))
-
- ;; Create /.singularity.d/actions, and optionally the 'run'
- ;; script, used by 'singularity run'.
- "-p" "/.singularity.d/actions d 555 0 0"
-
- ,@(if entry-point
- `(;; This one if for Singularity 2.x.
- "-p"
- ,(string-append
- "/.singularity.d/actions/run s 777 0 0 "
- (relative-file-name "/.singularity.d/actions"
- (string-append #$profile "/"
- entry-point)))
-
- ;; This one is for Singularity 3.x.
- "-p"
- ,(string-append
- "/.singularity.d/runscript s 777 0 0 "
- (relative-file-name "/.singularity.d"
- (string-append #$profile "/"
- entry-point))))
- '())
-
- ;; Create empty mount points.
- "-p" "/proc d 555 0 0"
- "-p" "/sys d 555 0 0"
- "-p" "/dev d 555 0 0"
- "-p" "/home d 555 0 0"))
-
- (when database
- ;; Initialize /var/guix.
- (install-database-and-gc-roots "var-etc" database #$profile)
- (mksquashfs `("var-etc" ,#$output))))))
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (guix build store-copy)
+ (guix build union)
+ (gnu build install))
+ #:select? not-config?)
+ #~(begin
+ (use-modules (guix build utils)
+ (guix build store-copy)
+ ((guix build union) #:select (relative-file-name))
+ (gnu build install)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 match))
+
+ (define database #+database)
+ (define entry-point #$entry-point)
+
+ (define (mksquashfs args)
+ (apply invoke "mksquashfs"
+ `(,@args
+
+ ;; Do not create a "recovery file" when appending to the
+ ;; file system since it's useless in this case.
+ "-no-recovery"
+
+ ;; Do not attempt to store extended attributes.
+ ;; See <https://bugs.gnu.org/40043>.
+ "-no-xattrs"
+
+ ;; Set file times and the file system creation time to
+ ;; one second after the Epoch.
+ "-all-time" "1" "-mkfs-time" "1"
+
+ ;; Reset all UIDs and GIDs.
+ "-force-uid" "0" "-force-gid" "0")))
+
+ (setenv "PATH" #+(file-append archiver "/bin"))
+
+ ;; We need an empty file in order to have a valid file argument when
+ ;; we reparent the root file system. Read on for why that's
+ ;; necessary.
+ (with-output-to-file ".empty" (lambda () (display "")))
+
+ ;; Create the squashfs image in several steps.
+ ;; Add all store items. Unfortunately mksquashfs throws away all
+ ;; ancestor directories and only keeps the basename. We fix this
+ ;; in the following invocations of mksquashfs.
+ (mksquashfs `(,@(map store-info-item
+ (call-with-input-file "profile"
+ read-reference-graph))
+ #$environment
+ ,#$output
+
+ ;; Do not perform duplicate checking because we
+ ;; don't have any dupes.
+ "-no-duplicates"
+ "-comp"
+ ,#+(compressor-name compressor)))
+
+ ;; Here we reparent the store items. For each sub-directory of
+ ;; the store prefix we need one invocation of "mksquashfs".
+ (for-each (lambda (dir)
+ (mksquashfs `(".empty"
+ ,#$output
+ "-root-becomes" ,dir)))
+ (reverse (string-tokenize (%store-directory)
+ (char-set-complement (char-set #\/)))))
+
+ ;; Add symlinks and mount points.
+ (mksquashfs
+ `(".empty"
+ ,#$output
+ ;; Create SYMLINKS via pseudo file definitions.
+ ,@(append-map
+ (match-lambda
+ ((source '-> target)
+ ;; Create relative symlinks to work around a bug in
+ ;; Singularity 2.x:
+ ;; https://bugs.gnu.org/34913
+ ;; https://github.com/sylabs/singularity/issues/1487
+ (let ((target (string-append #$profile "/" target)))
+ (list "-p"
+ (string-join
+ ;; name s mode uid gid symlink
+ (list source
+ "s" "777" "0" "0"
+ (relative-file-name (dirname source)
+ target)))))))
+ '#$symlinks*)
+
+ "-p" "/.singularity.d d 555 0 0"
+
+ ;; Create the environment file.
+ "-p" "/.singularity.d/env d 555 0 0"
+ "-p" ,(string-append
+ "/.singularity.d/env/90-environment.sh s 777 0 0 "
+ (relative-file-name "/.singularity.d/env"
+ #$environment))
+
+ ;; Create /.singularity.d/actions, and optionally the 'run'
+ ;; script, used by 'singularity run'.
+ "-p" "/.singularity.d/actions d 555 0 0"
+
+ ,@(if entry-point
+ `( ;; This one if for Singularity 2.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/actions/run s 777 0 0 "
+ (relative-file-name "/.singularity.d/actions"
+ (string-append #$profile "/"
+ entry-point)))
+
+ ;; This one is for Singularity 3.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/runscript s 777 0 0 "
+ (relative-file-name "/.singularity.d"
+ (string-append #$profile "/"
+ entry-point))))
+ '())
+
+ ;; Create empty mount points.
+ "-p" "/proc d 555 0 0"
+ "-p" "/sys d 555 0 0"
+ "-p" "/dev d 555 0 0"
+ "-p" "/home d 555 0 0"))
+
+ (when database
+ ;; Initialize /var/guix.
+ (install-database-and-gc-roots "var-etc" database #$profile)
+ (mksquashfs `("var-etc" ,#$output)))))))
(gexp->derivation (string-append name
(compressor-extension compressor)
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index b4d37d4525..8564f12107 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -34,7 +34,8 @@
#:use-module (guix serialization)
#:export (nar-sha256
deduplicate
- dump-file/deduplicate))
+ dump-file/deduplicate
+ copy-file/deduplicate))
;; 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
@@ -256,3 +257,16 @@ down the road."
(get-hash)))))
(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)))))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index a0e55178fa..6e92f0e4b3 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -736,7 +736,8 @@
(zero? (logand #o222 (stat:mode st)))))))
(mkdir #$output)
- (populate-store '("graph") #$output)
+ (populate-store '("graph") #$output
+ #:deduplicate? #f)
;; Check whether 'populate-store' canonicalizes
;; permissions and timestamps.
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index e2870a363d..7b01acae24 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -1,5 +1,5 @@
;;; 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.
;;;
@@ -25,6 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64))
(test-begin "store-deduplication")
@@ -106,4 +107,19 @@
(cons (apply = (map (compose stat:ino 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")
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 08/15] image: 'register-closure' leaves it up to the caller to deduplicate.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (6 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 07/15] store-copy: 'populate-store' can optionally deduplicate files Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-11 15:09 ` bug#44760: [PATCH 09/15] database: Remove #:deduplicate? from 'register-items' Ludovic Courtès
2020-12-15 16:33 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
* gnu/build/image.scm (register-closure): Remove #:deduplicate?
parameter and pass #:deduplicate? #f to 'register-items'.
(initialize-root-partition): Adjust accordingly.
* gnu/build/vm.scm (register-closure, root-partition-initializer):
Likewise.
---
gnu/build/image.scm | 8 ++------
gnu/build/vm.scm | 9 +++------
2 files changed, 5 insertions(+), 12 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 8f50f27f78..8d5fc603d9 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -140,21 +140,18 @@ given CONFIG file."
(define* (register-closure prefix closure
#:key
- (deduplicate? #t)
(schema (sql-schema))
(wal-mode? #t))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs. As a side effect, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX. Pass WAL-MODE?
-to call-with-database."
+produced by #:references-graphs. Pass WAL-MODE? to call-with-database."
(let ((items (call-with-input-file closure read-reference-graph)))
(parameterize ((sql-schema schema))
(with-database (store-database-file #:prefix prefix) db
#:wal-mode? wal-mode?
(register-items db items
#:prefix prefix
- #:deduplicate? deduplicate?
+ #:deduplicate? #f
#:registration-time %epoch)))))
(define* (initialize-efi-partition root
@@ -196,7 +193,6 @@ register-closure."
(when register-closures?
(for-each (lambda (closure)
(register-closure root closure
- #:deduplicate? #f
#:wal-mode? wal-mode?))
references-graphs))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 03be5697b7..8c6ab648ac 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -215,18 +215,16 @@ the #:references-graphs parameter of 'derivation'."
(define* (register-closure prefix closure
#:key
- (deduplicate? #t)
(schema (sql-schema)))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs. As a side effect, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX."
+produced by #:references-graphs."
(let ((items (call-with-input-file closure read-reference-graph)))
(parameterize ((sql-schema schema))
(with-database (store-database-file #:prefix prefix) db
(register-items db items
#:prefix prefix
- #:deduplicate? deduplicate?
+ #:deduplicate? #f
#:registration-time %epoch)))))
\f
@@ -412,8 +410,7 @@ system that is passed to 'populate-root-file-system'."
(display "registering closures...\n")
(for-each (lambda (closure)
(register-closure target
- (string-append "/xchg/" closure)
- #:deduplicate? #f))
+ (string-append "/xchg/" closure)))
closures)
(unless copy-closures?
(umount target-store)))
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 09/15] database: Remove #:deduplicate? from 'register-items'.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (7 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 08/15] image: 'register-closure' leaves it up to the caller to deduplicate Ludovic Courtès
@ 2020-12-11 15:09 ` Ludovic Courtès
2020-12-15 16:33 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-11 15:09 UTC (permalink / raw)
To: 44760
It is now up to the caller to deduplicate store contents.
* guix/store/database.scm (register-items): Remove #:deduplicate?
parameter and call to 'deduplicate'.
(register-path): Call 'deduplicate' when #:deduplicate? is true.
* gnu/build/image.scm (register-closure): Adjust call accordingly.
* gnu/build/vm.scm (register-closure): Likewise.
* guix/nar.scm (finalize-store-file): Likewise.
* guix/scripts/pack.scm (store-database): Likewise.
---
gnu/build/image.scm | 1 -
gnu/build/vm.scm | 1 -
guix/nar.scm | 3 +--
guix/scripts/pack.scm | 1 -
guix/store/database.scm | 11 ++++++-----
5 files changed, 7 insertions(+), 10 deletions(-)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 8d5fc603d9..f6e5cb42f6 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -151,7 +151,6 @@ produced by #:references-graphs. Pass WAL-MODE? to call-with-database."
#:wal-mode? wal-mode?
(register-items db items
#:prefix prefix
- #:deduplicate? #f
#:registration-time %epoch)))))
(define* (initialize-efi-partition root
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 8c6ab648ac..bd59916bf3 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -224,7 +224,6 @@ produced by #:references-graphs."
(with-database (store-database-file #:prefix prefix) db
(register-items db items
#:prefix prefix
- #:deduplicate? #f
#:registration-time %epoch)))))
\f
diff --git a/guix/nar.scm b/guix/nar.scm
index 947b393d84..a817b56007 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -118,8 +118,7 @@ held."
;; Register TARGET. The 'restore-file' call took care of
;; deduplication, timestamps, and permissions.
(register-items db
- (list (store-info target deriver references))
- #:deduplicate? #f))
+ (list (store-info target deriver references))))
(when lock?
(delete-file (string-append target ".lock"))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 440c4b0903..8ecdcb823f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -167,7 +167,6 @@ dependencies are registered."
(let ((items (append-map read-closure '#$labels)))
(with-database db-file db
(register-items db items
- #:deduplicate? #f
#:registration-time %epoch)))))))
(computed-file "store-database" build
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 0ed66a6e2c..31ea9add78 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -407,6 +407,11 @@ by adding it as a temp-root."
(define real-file-name
(string-append (or prefix "") path))
+ (when deduplicate?
+ (deduplicate real-file-name (nar-sha256 real-file-name)
+ #:store (string-append (or prefix "")
+ %store-directory)))
+
(when reset-timestamps?
(reset-timestamps real-file-name))
@@ -414,7 +419,6 @@ by adding it as a temp-root."
(with-database db-file db
(register-items db (list (store-info path deriver references))
#:prefix prefix
- #:deduplicate? deduplicate?
#:log-port (%make-void-port "w")))))
(define %epoch
@@ -423,7 +427,6 @@ by adding it as a temp-root."
(define* (register-items db items
#:key prefix
- (deduplicate? #t)
registration-time
(log-port (current-error-port)))
"Register all of ITEMS, a list of <store-info> records as returned by
@@ -467,9 +470,7 @@ typically by adding them as temp-roots."
"sha256:"
(bytevector->base16-string hash))
#:nar-size nar-size
- #:time registration-time)))
- (when deduplicate?
- (deduplicate real-file-name hash #:store store-dir)))))
+ #:time registration-time))))))
(let* ((prefix (format #f "registering ~a items" (length items)))
(progress (progress-reporter/bar (length items)
--
2.29.2
^ permalink raw reply related [flat|nested] 23+ messages in thread* bug#44760: [PATCH 00/15] Speed up 'guix system init' & co.
2020-12-11 15:09 ` bug#44760: [PATCH 00/15] Speed up 'guix system init' & co Ludovic Courtès
` (8 preceding siblings ...)
2020-12-11 15:09 ` bug#44760: [PATCH 09/15] database: Remove #:deduplicate? from 'register-items' Ludovic Courtès
@ 2020-12-15 16:33 ` Ludovic Courtès
9 siblings, 0 replies; 23+ messages in thread
From: Ludovic Courtès @ 2020-12-15 16:33 UTC (permalink / raw)
To: 44760-done
Ludovic Courtès <ludo@gnu.org> skribis:
> serialization: 'fold-archive' notifies about directory processing
> completion.
> serialization: 'restore-file' sets canonical timestamp and
> permissions.
> nar: Deduplicate files right as they are restored.
> store-copy: 'populate-store' resets timestamps.
> image: 'register-closure' assumes already-reset timestamps.
> database: Remove #:reset-timestamps? from 'register-items'.
> store-copy: 'populate-store' can optionally deduplicate files.
> image: 'register-closure' leaves it up to the caller to deduplicate.
> database: Remove #:deduplicate? from 'register-items'.
> guix system: 'init' copies, resets timestamps, and deduplicates at
> once.
> database: Remove #:deduplicate? and #:reset-timestamps? from
> 'register-path'.
> system: 'init' does not recompute the hash of each store item.
> database: Remove 'register-path'.
> database: Honor 'SOURCE_DATE_EPOCH'.
> deduplicate: Create the '.links' directory lazily.
Pushed as 7530e491b517497b7b8166b5ccecdc3d4cdb468d!
Ludo'.
^ permalink raw reply [flat|nested] 23+ messages in thread