From 8bc5ca5160db3d82bd5b6b2b7ed80c96f42bd33e Mon Sep 17 00:00:00 2001 From: Paul Garlick Date: Thu, 3 Dec 2020 16:00:18 +0000 Subject: linux-container: Correct test for unprivileged user namespace support. Fixes . Reported by Paul Garlick . * gnu/build/linux-container.scm (unprivileged-user-namespace-supported?): Return #f when the 'userns-file' does not exist. --- gnu/build/linux-container.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 4a8bed5a9a..3870b50907 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -44,7 +44,7 @@ (let ((userns-file "/proc/sys/kernel/unprivileged_userns_clone")) (if (file-exists? userns-file) (eqv? #\1 (call-with-input-file userns-file read-char)) - #t))) + #f))) (define (setgroups-supported?) "Return #t if the setgroups proc file, introduced in Linux-libre 3.19, -- cgit 1.4.1 From 23be018d4fe1150ca81efb3572cd695a9044b80d Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 6 Dec 2020 11:14:48 +0100 Subject: file-systems: Fix ‘bcachefs fsck’ exit value logic. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bit 1 means the target device was mounted read-only whilst checking. This should never happen in an initrd context but is not an error. * gnu/build/file-systems.scm (check-bcachefs-file-system): Ignore status bits that don't signal an error. Remove the 'reboot-required case. --- gnu/build/file-systems.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index b762e82ad2..ddf6117b67 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -262,14 +262,16 @@ bytevector." (define (check-bcachefs-file-system device) "Return the health of a bcachefs file system on DEVICE." - (match (status:exit-val + (let ((ignored-bits (logior 2)) ; DEVICE was mounted read-only + (status + (status:exit-val (apply system* "bcachefs" "fsck" "-p" "-v" ;; Make each multi-device member a separate argument. - (string-split device #\:))) - (0 'pass) - (1 'errors-corrected) - (2 'reboot-required) - (_ 'fatal-error))) + (string-split device #\:))))) + (match (logand (lognot ignored-bits) status) + (0 'pass) + (1 'errors-corrected) + (_ 'fatal-error)))) ;;; -- cgit 1.4.1 From 329fa5bdbb621dae586cbfb062cbd3b295880ba5 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sun, 6 Dec 2020 21:55:18 +0100 Subject: Revert "linux-container: Correct test for unprivileged user namespace support." This broke 'guix environment --container' on non-Debian distributions. Fixes . Reported by luhux . This reverts commit 8bc5ca5160db3d82bd5b6b2b7ed80c96f42bd33e. --- gnu/build/linux-container.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 3870b50907..4a8bed5a9a 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -44,7 +44,7 @@ (let ((userns-file "/proc/sys/kernel/unprivileged_userns_clone")) (if (file-exists? userns-file) (eqv? #\1 (call-with-input-file userns-file read-char)) - #f))) + #t))) (define (setgroups-supported?) "Return #t if the setgroups proc file, introduced in Linux-libre 3.19, -- cgit 1.4.1 From 7b8d239ec241b9663820fed3bfde4344366f9d19 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 13:37:59 +0100 Subject: store-copy: 'populate-store' resets timestamps. 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(-) (limited to 'gnu/build') 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 +;;; Copyright © 2013, 2014, 2017, 2018, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (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 , 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 -- cgit 1.4.1 From 0f15fd5c12e53c5e5307943f69ab25c0486244e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 14:01:03 +0100 Subject: image: 'register-closure' assumes already-reset timestamps. * 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(-) (limited to 'gnu/build') 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))))) @@ -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? -- cgit 1.4.1 From dea1ee1fd740248307f74ca4cb70b94742264098 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 14:15:05 +0100 Subject: database: Remove #:reset-timestamps? from 'register-items'. 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(-) (limited to 'gnu/build') 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))))) 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 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 () -- cgit 1.4.1 From 6a060ff27ff68384d7c90076baa36c349fff689d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 15:12:34 +0100 Subject: 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'. --- 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 | 258 ++++++++++++++++++++++-------------------- guix/store/deduplication.scm | 16 ++- tests/gexp.scm | 3 +- tests/store-deduplication.scm | 18 ++- 11 files changed, 207 insertions(+), 139 deletions(-) (limited to 'gnu/build') 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 a6b9e3d952..e753463473 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017 Marius Bakke @@ -176,6 +176,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)) @@ -190,7 +197,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)) + (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 database #+database) + (define entry-point #$entry-point) - (define (mksquashfs args) - (apply invoke "mksquashfs" - `(,@args + (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 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 . - "-no-xattrs" + ;; Do not attempt to store extended attributes. + ;; See . + "-no-xattrs" - ;; Set file times and the file system creation time to - ;; one second after the Epoch. - "-all-time" "1" "-mkfs-time" "1" + ;; 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"))) + ;; Reset all UIDs and GIDs. + "-force-uid" "0" "-force-gid" "0"))) - (setenv "PATH" #+(file-append archiver "/bin")) + (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)))))) + ;; 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 +;;; Copyright © 2018, 2020 Ludovic Courtès ;;; ;;; 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") -- cgit 1.4.1 From 2aa512ec2843991804b5bf345c80abdb2b993bdc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 21:25:39 +0100 Subject: image: 'register-closure' leaves it up to the caller to deduplicate. * 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(-) (limited to 'gnu/build') 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))))) @@ -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))) -- cgit 1.4.1 From 0793833c59e727d5d471fe46c8e0e44c811b9621 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 21:42:02 +0100 Subject: database: Remove #:deduplicate? from 'register-items'. 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(-) (limited to 'gnu/build') 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))))) 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 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) -- cgit 1.4.1 From 2072f617adfbdb2ab6ba032158ecc7eb75a150ec Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 15 Dec 2020 21:55:34 +0100 Subject: linux-boot: Fix noresume argument parsing. * gnu/build/linux-boot.scm (boot-system): Check for "hibernate=noresume" in addition to "noresume". --- gnu/build/linux-boot.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index bfaac9ec1f..f20eeaac9f 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -560,7 +560,10 @@ upon error." (load-linux-modules-from-directory linux-modules linux-module-directory) - (unless (member "noresume" args) + (unless (or (member "hibernate=noresume" args) + ;; Also handle the equivalent old-style argument. + ;; See Documentation/admin-guide/kernel-parameters.txt. + (member "noresume" args)) ;; Try to resume immediately after loading (storage) modules ;; but before any on-disk file systems have been mounted. (false-if-exception ; failure is not fatal -- cgit 1.4.1