From 465d2cb286170933577de045e6e6dad7205bfe10 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Dec 2020 21:50:21 +0100 Subject: serialization: 'fold-archive' notifies about directory processing completion. * 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. --- tests/nar.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'tests') 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; 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) -- cgit v1.2.3 From ed7d02f7c198970ce3fe94bcee47592963326446 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Dec 2020 22:16:35 +0100 Subject: serialization: 'restore-file' sets canonical timestamp and permissions. * 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(-) (limited to 'tests') 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 +# Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès # # 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))))))) -- cgit v1.2.3 From 2718c29c3fb9f9de2ec897248ad49ae11ca39b7a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Dec 2020 11:21:14 +0100 Subject: nar: Deduplicate files right as they are restored. 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 : 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(-) (limited to 'tests') 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) -- cgit v1.2.3 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 'tests') 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 v1.2.3 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 'tests') 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 v1.2.3 From 0682cc593688e7d9a435ca69f05320aa87df06d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Dec 2020 12:03:25 +0100 Subject: database: Remove #:deduplicate? and #:reset-timestamps? from 'register-path'. * guix/store/database.scm (register-path): Remove #:deduplicate? and #:reset-timestamps?. * guix/scripts/system.scm (copy-item): Adjust accordingly. * tests/store-database.scm ("register-path") ("register-path, directory"): Call 'reset-timestamps'. --- guix/scripts/system.scm | 6 +----- guix/store/database.scm | 17 ++--------------- tests/store-database.scm | 5 +++-- 3 files changed, 6 insertions(+), 22 deletions(-) (limited to 'tests') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index c08929066b..0e543d9460 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -158,11 +158,7 @@ REFERENCES as its set of references." (unless (register-path item #:prefix target #:state-directory state - #:references references - - ;; Those are taken care of by 'copy-store-item'. - #:reset-timestamps? #f - #:deduplicate? #f) + #:references references) (leave (G_ "failed to register '~a' under '~a'~%") item target)))) diff --git a/guix/store/database.scm b/guix/store/database.scm index 31ea9add78..c0010b72b9 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -384,16 +384,14 @@ is true." (define* (register-path path #:key (references '()) deriver prefix - state-directory (deduplicate? #t) - (reset-timestamps? #t) + state-directory (schema (sql-schema))) "Register PATH as a valid store file, with REFERENCES as its list of 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. As a side effect, reset timestamps on PATH, unless -RESET-TIMESTAMPS? is false. +Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook. @@ -404,17 +402,6 @@ 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 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)) - (parameterize ((sql-schema schema)) (with-database db-file db (register-items db (list (store-info path deriver references)) diff --git a/tests/store-database.scm b/tests/store-database.scm index 3b4ef43f6d..33fd6cfbad 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -34,8 +34,7 @@ (test-begin "store-database") -(test-equal "register-path" - '(1 1) +(test-assert "register-path" (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake"))) (when (valid-path? %store file) @@ -46,6 +45,7 @@ (drv (string-append file ".drv"))) (call-with-output-file file (cut display "This is a fake store item.\n" <>)) + (reset-timestamps file) (register-path file #:references (list ref) #:deriver drv) @@ -69,6 +69,7 @@ (mkdir-p (string-append file "/a")) (call-with-output-file (string-append file "/a/b") (const #t)) + (reset-timestamps file) (register-path file #:deriver drv) (and (valid-path? %store file) -- cgit v1.2.3 From 3169c93903c20cea000335d59560eac7f28e8f92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Dec 2020 14:46:20 +0100 Subject: database: Remove 'register-path'. * guix/store/database.scm (register-path): Remove. * tests/store-database.scm ("register-path"): Rename to... ("register-items"): ... this, and use 'register-items' instead of 'register-path'. ("register-path, directory"): Rename to... ("register-items, directory"): ... this, and use 'register-items' instead of 'register-path'. ("register-path with unregistered references"): Rename to... ("sqlite-register with unregistered references"): ... this. --- guix/store/database.scm | 27 --------------------------- tests/store-database.scm | 15 ++++++++------- 2 files changed, 8 insertions(+), 34 deletions(-) (limited to 'tests') diff --git a/guix/store/database.scm b/guix/store/database.scm index 9d5bc531bb..4579b05261 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -43,7 +43,6 @@ with-database path-id sqlite-register - register-path register-items %epoch reset-timestamps)) @@ -383,32 +382,6 @@ is true." (chmod file (if (executable-file? file) #o555 #o444))) (utime file 1 1 0 0))))) -(define* (register-path path - #:key (references '()) deriver prefix - state-directory - (schema (sql-schema))) - "Register PATH as a valid store file, with REFERENCES as its list of -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. - -Use with care as it directly modifies the store! This is primarily meant to -be used internally by the daemon's build hook. - -PATH must be protected from GC and locked during execution of this, typically -by adding it as a temp-root." - (define db-file - (store-database-file #:prefix prefix - #:state-directory state-directory)) - - (parameterize ((sql-schema schema)) - (with-database db-file db - (register-items db (list (store-info path deriver references)) - #:prefix prefix - #:log-port (%make-void-port "w"))))) - (define %epoch ;; When it all began. (make-time time-utc 0 1)) diff --git a/tests/store-database.scm b/tests/store-database.scm index 33fd6cfbad..17eea38c63 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix store database) + #:use-module (guix build store-copy) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively)) @@ -34,7 +35,7 @@ (test-begin "store-database") -(test-assert "register-path" +(test-assert "register-items" (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake"))) (when (valid-path? %store file) @@ -46,9 +47,8 @@ (call-with-output-file file (cut display "This is a fake store item.\n" <>)) (reset-timestamps file) - (register-path file - #:references (list ref) - #:deriver drv) + (with-database (store-database-file) db + (register-items db (list (store-info file drv (list ref))))) (and (valid-path? %store file) (equal? (references %store file) (list ref)) @@ -57,7 +57,7 @@ (list (stat:mtime (lstat file)) (stat:mtime (lstat ref))))))) -(test-equal "register-path, directory" +(test-equal "register-items, directory" '(1 1 1) (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake-directory"))) @@ -70,7 +70,8 @@ (call-with-output-file (string-append file "/a/b") (const #t)) (reset-timestamps file) - (register-path file #:deriver drv) + (with-database (store-database-file) db + (register-items db (list (store-info file drv '())))) (and (valid-path? %store file) (null? (references %store file)) @@ -102,7 +103,7 @@ (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) -(test-assert "register-path with unregistered references" +(test-assert "sqlite-register with unregistered references" ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error ;; when we try to add references that are not registered yet. Better safe ;; than sorry. -- cgit v1.2.3 From 7530e491b517497b7b8166b5ccecdc3d4cdb468d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Dec 2020 15:48:02 +0100 Subject: deduplicate: Create the '.links' directory lazily. This avoids repeated (mkdir-p "/gnu/store/.links") calls when deduplicating lots of files. * guix/store/deduplication.scm (deduplicate): Remove initial call to 'mkdir-p'. Add ENOENT case in 'link' exception handler. Reindent. * tests/store-deduplication.scm ("deduplicate, ENOSPC"): Check for (<= links 4) to account for the initial 'link' call. --- guix/store/deduplication.scm | 96 ++++++++++++++++++++++--------------------- tests/store-deduplication.scm | 2 +- 2 files changed, 51 insertions(+), 47 deletions(-) (limited to 'tests') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 8564f12107..a72a43bf79 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -159,52 +159,56 @@ under STORE." (define links-directory (string-append store "/.links")) - (mkdir-p links-directory) - (let loop ((path path) - (type (stat:type (lstat path))) - (hash hash)) - (if (eq? 'directory type) - ;; Can't hardlink directories, so hardlink their atoms. - (for-each (match-lambda - ((file . properties) - (unless (member file '("." "..")) - (let* ((file (string-append path "/" file)) - (type (match (assoc-ref properties 'type) - ((or 'unknown #f) - (stat:type (lstat file))) - (type type)))) - (loop file type - (and (not (eq? 'directory type)) - (nar-sha256 file))))))) - (scandir* path)) - (let ((link-file (string-append links-directory "/" - (bytevector->nix-base32-string hash)))) - (if (file-exists? link-file) - (replace-with-link link-file path - #:swap-directory links-directory - #:store store) - (catch 'system-error - (lambda () - (link path link-file)) - (lambda args - (let ((errno (system-error-errno args))) - (cond ((= errno EEXIST) - ;; Someone else put an entry for PATH in - ;; LINKS-DIRECTORY before we could. Let's use it. - (replace-with-link path link-file - #:swap-directory - links-directory - #:store store)) - ((= errno ENOSPC) - ;; There's not enough room in the directory index for - ;; more entries in .links, but that's fine: we can - ;; just stop. - #f) - ((= errno EMLINK) - ;; PATH has reached the maximum number of links, but - ;; that's OK: we just can't deduplicate it more. - #f) - (else (apply throw args))))))))))) + (let loop ((path path) + (type (stat:type (lstat path))) + (hash hash)) + (if (eq? 'directory type) + ;; Can't hardlink directories, so hardlink their atoms. + (for-each (match-lambda + ((file . properties) + (unless (member file '("." "..")) + (let* ((file (string-append path "/" file)) + (type (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))) + (loop file type + (and (not (eq? 'directory type)) + (nar-sha256 file))))))) + (scandir* path)) + (let ((link-file (string-append links-directory "/" + (bytevector->nix-base32-string hash)))) + (if (file-exists? link-file) + (replace-with-link link-file path + #:swap-directory links-directory + #:store store) + (catch 'system-error + (lambda () + (link path link-file)) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EEXIST) + ;; Someone else put an entry for PATH in + ;; LINKS-DIRECTORY before we could. Let's use it. + (replace-with-link path link-file + #:swap-directory + links-directory + #:store store)) + ((= errno ENOENT) + ;; This most likely means that LINKS-DIRECTORY does + ;; not exist. Attempt to create it and try again. + (mkdir-p links-directory) + (loop path type hash)) + ((= errno ENOSPC) + ;; There's not enough room in the directory index for + ;; more entries in .links, but that's fine: we can + ;; just stop. + #f) + ((= errno EMLINK) + ;; PATH has reached the maximum number of links, but + ;; 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 diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 7b01acae24..b1c2d93bbd 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -95,7 +95,7 @@ (lambda () (set! link (lambda (old new) (set! links (+ links 1)) - (if (<= links 3) + (if (<= links 4) (true-link old new) (throw 'system-error "link" "~A" '("Whaaat?!") (list ENOSPC)))))) -- cgit v1.2.3 From 6d955f1731dc593a51625b455882102a67d95e1a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Dec 2020 22:20:08 +0100 Subject: tests: Check the build trace for hash mismatches on substitutes. * tests/store.scm ("substitute, corrupt output hash, build trace"): New test. --- tests/store.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 38051bf5e5..7f1ec51875 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -787,6 +787,61 @@ (build-derivations s (list d)) #f)))))) +(test-assert "substitute, corrupt output hash, build trace" + ;; Likewise, and check the build trace. + (with-store s + (let* ((c "hello, world") ; contents of the output + (d (build-expression->derivation + s "corrupt-substitute" + `(mkdir %output) + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation->output-path d))) + ;; Make sure we use 'guix substitute'. + (set-build-options s + #:print-build-trace #t + #:use-substitutes? #t + #:fallback? #f + #:substitute-urls (%test-substitute-urls)) + + (with-derivation-substitute d c + (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C + + (define output + (call-with-output-string + (lambda (port) + (parameterize ((current-build-output-port port)) + (guard (c ((store-protocol-error? c) #t)) + (build-derivations s (list d)) + #f))))) + + (define actual-hash + (let-values (((port get-hash) + (gcrypt:open-hash-port + (gcrypt:hash-algorithm gcrypt:sha256)))) + (write-file-tree "foo" port + #:file-type+size + (lambda _ + (values 'regular (string-length c))) + #:file-port + (lambda _ + (open-input-string c))) + (close-port port) + (bytevector->nix-base32-string (get-hash)))) + + (define expected-hash + (bytevector->nix-base32-string (make-bytevector 32 0))) + + (define mismatch + (string-append "@ hash-mismatch " o " sha256 " + expected-hash " " actual-hash "\n")) + + (define failure + (string-append "@ substituter-failed " o)) + + (and (string-contains output mismatch) + (string-contains output failure)))))) + (test-assert "substitute --fallback" (with-store s (let* ((t (random-text)) ; contents of the output -- cgit v1.2.3 From 9dfa20a22ae0be3d3b01a7b3d422af97428c627e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Dec 2020 22:46:03 +0100 Subject: daemon: Let 'guix substitute' perform hash checks. This way, the hash of the store item can be computed as it is restored, thereby avoiding an additional file tree traversal ('hashPath' call) later on in the daemon. Consequently, it should reduce latency between subsequent substitute downloads. This is a followup to 5ff521452b9ec2aae9ed8e4bb7bdc250a581f203. * guix/scripts/substitute.scm (narinfo-hash-algorithm+value): New procedure. (process-substitution): Wrap INPUT into a hash input port, 'hashed', and read from it. Compare the actual and expected hashes, and print a "hash-mismatch" status line when they differ. When they match, print not just "success" but also the nar hash and size. * nix/libstore/build.cc (class SubstitutionGoal)[expectedHashStr]: Remove. (SubstitutionGoal::finished): Tokenize 'status'. Parse it and handle "success" and "hash-mismatch" accordingly. Call 'hashPath' only when the returned hash is not SHA256. (SubstitutionGoal::handleChildOutput): Remove 'expectedHashStr' handling. * tests/substitute.scm ("substitute, invalid hash"): Rename to... ("substitute, invalid narinfo hash"): ... this. ("substitute, invalid hash"): New test. --- guix/scripts/substitute.scm | 45 +++++++++++++++++++++++----- nix/libstore/build.cc | 73 ++++++++++++++++++++++++--------------------- tests/substitute.scm | 50 +++++++++++++++++++++++++++++-- 3 files changed, 124 insertions(+), 44 deletions(-) (limited to 'tests') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 25075eedff..17d0002b9f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -26,6 +26,8 @@ #:use-module (guix combinators) #:use-module (guix config) #:use-module (guix records) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module ((guix serialization) #:select (restore-file)) #:autoload (guix scripts discover) (read-substitute-urls) #:use-module (gcrypt hash) @@ -256,6 +258,18 @@ connection (typically PORT) is kept open once data has been fetched from URI." ;; for more information. (contents narinfo-contents)) +(define (narinfo-hash-algorithm+value narinfo) + "Return two values: the hash algorithm used by NARINFO and its value as a +bytevector." + (match (string-tokenize (narinfo-hash narinfo) + (char-set-complement (char-set #\:))) + ((algorithm base32) + (values (lookup-hash-algorithm (string->symbol algorithm)) + (nix-base32-string->bytevector base32))) + (_ + (raise (formatted-message + (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) + (define (narinfo-hash->sha256 hash) "If the string HASH denotes a sha256 hash, return it as a bytevector. Otherwise return #f." @@ -1033,7 +1047,9 @@ one. Return #f if URI's scheme is 'file' or #f." (define* (process-substitution store-item destination #:key cache-urls acl print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to -DESTINATION as a nar file. Verify the substitute against ACL." +DESTINATION as a nar file. Verify the substitute against ACL, and verify its +hash against what appears in the narinfo. Print a status line on the current +output port." (define narinfo (lookup-narinfo cache-urls store-item (cut valid-narinfo? <> acl))) @@ -1044,9 +1060,6 @@ DESTINATION as a nar file. Verify the substitute against ACL." (let-values (((uri compression file-size) (narinfo-best-uri narinfo))) - ;; Tell the daemon what the expected hash of the Nar itself is. - (format #t "~a~%" (narinfo-hash narinfo)) - (unless print-build-trace? (format (current-error-port) (G_ "Downloading ~a...~%") (uri->string uri))) @@ -1079,9 +1092,16 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; closed here, while the child process doing the ;; reporting will close it upon exit. (decompressed-port (string->symbol compression) - progress))) + progress)) + + ;; Compute the actual nar hash as we read it. + ((algorithm expected) + (narinfo-hash-algorithm+value narinfo)) + ((hashed get-hash) + (open-hash-input-port algorithm input))) ;; Unpack the Nar at INPUT into DESTINATION. - (restore-file input destination) + (restore-file hashed destination) + (close-port hashed) (close-port input) ;; Wait for the reporter to finish. @@ -1091,8 +1111,17 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; one to visually separate substitutions. (display "\n\n" (current-error-port)) - ;; Tell the daemon that we're done. - (display "success\n" (current-output-port))))) + ;; Check whether we got the data announced in NARINFO. + (let ((actual (get-hash))) + (if (bytevector=? actual expected) + ;; Tell the daemon that we're done. + (format (current-output-port) "success ~a ~a~%" + (narinfo-hash narinfo) (narinfo-size narinfo)) + ;; The actual data has a different hash than that in NARINFO. + (format (current-output-port) "hash-mismatch ~a ~a ~a~%" + (hash-algorithm-name algorithm) + (bytevector->nix-base32-string expected) + (bytevector->nix-base32-string actual))))))) ;;; diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index b5551b87ae..b19471a68f 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -2790,10 +2790,6 @@ private: /* The substituter. */ std::shared_ptr substituter; - /* Either the empty string, or the expected hash as returned by the - substituter. */ - string expectedHashStr; - /* Either the empty string, or the status phrase returned by the substituter. */ string status; @@ -3032,36 +3028,47 @@ void SubstitutionGoal::finished() /* Check the exit status and the build result. */ HashResult hash; try { - - if (status != "success") - throw SubstError(format("fetching path `%1%' (status: '%2%')") - % storePath % status); - - if (!pathExists(destPath)) - throw SubstError(format("substitute did not produce path `%1%'") % destPath); - - if (expectedHashStr == "") - throw SubstError(format("substituter did not communicate hash for `%1'") % storePath); - - hash = hashPath(htSHA256, destPath); - - /* Verify the expected hash we got from the substituer. */ - size_t n = expectedHashStr.find(':'); - if (n == string::npos) - throw Error(format("bad hash from substituter: %1%") % expectedHashStr); - HashType hashType = parseHashType(string(expectedHashStr, 0, n)); - if (hashType == htUnknown) - throw Error(format("unknown hash algorithm in `%1%'") % expectedHashStr); - Hash expectedHash = parseHash16or32(hashType, string(expectedHashStr, n + 1)); - Hash actualHash = hashType == htSHA256 ? hash.first : hashPath(hashType, destPath).first; - if (expectedHash != actualHash) { - if (settings.printBuildTrace) + auto statusList = tokenizeString >(status); + + if (statusList.empty()) { + throw SubstError(format("fetching path `%1%' (empty status: '%2%')") + % storePath % status); + } else if (statusList[0] == "hash-mismatch") { + if (settings.printBuildTrace) { + auto hashType = statusList[1]; + auto expectedHash = statusList[2]; + auto actualHash = statusList[3]; printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%") - % storePath % "sha256" - % printHash16or32(expectedHash) - % printHash16or32(actualHash)); + % storePath + % hashType % expectedHash % actualHash); + } throw SubstError(format("hash mismatch for substituted item `%1%'") % storePath); + } else if (statusList[0] == "success") { + if (!pathExists(destPath)) + throw SubstError(format("substitute did not produce path `%1%'") % destPath); + + std::string hashStr = statusList[1]; + size_t n = hashStr.find(':'); + if (n == string::npos) + throw Error(format("bad hash from substituter: %1%") % hashStr); + + HashType hashType = parseHashType(string(hashStr, 0, n)); + switch (hashType) { + case htUnknown: + throw Error(format("unknown hash algorithm in `%1%'") % hashStr); + case htSHA256: + hash.first = parseHash16or32(hashType, string(hashStr, n + 1)); + hash.second = std::atoi(statusList[2].c_str()); + break; + default: + /* The database only stores SHA256 hashes, so compute it. */ + hash = hashPath(htSHA256, destPath); + break; + } } + else + throw SubstError(format("fetching path `%1%' (status: '%2%')") + % storePath % status); } catch (SubstError & e) { @@ -3123,9 +3130,7 @@ void SubstitutionGoal::handleChildOutput(int fd, const string & data) string trimmed = (end != string::npos) ? input.substr(0, end) : input; /* Update the goal's state accordingly. */ - if (expectedHashStr == "") { - expectedHashStr = trimmed; - } else if (status == "") { + if (status == "") { status = trimmed; worker.wakeUp(shared_from_this()); } else { diff --git a/tests/substitute.scm b/tests/substitute.scm index b86ce09425..5b42632552 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -28,7 +28,9 @@ #:use-module (guix base32) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) - #:use-module ((guix utils) #:select (call-with-compressed-output-port)) + #:use-module ((guix utils) + #:select (call-with-temporary-directory + call-with-compressed-output-port)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) @@ -36,6 +38,7 @@ #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -304,7 +307,7 @@ System: mips64el-linux\n") (lambda () (guix-substitute "--substitute"))))) -(test-quit "substitute, invalid hash" +(test-quit "substitute, invalid narinfo hash" "no valid substitute" ;; The hash in the signature differs from the hash of %NARINFO. (with-narinfo (string-append %narinfo "Signature: " @@ -317,6 +320,49 @@ System: mips64el-linux\n") (lambda () (guix-substitute "--substitute"))))) +(test-equal "substitute, invalid hash" + (string-append "hash-mismatch sha256 " + (bytevector->nix-base32-string (sha256 #vu8())) " " + (let-values (((port get-hash) + (open-hash-port (hash-algorithm sha256))) + ((content) + "Substitutable data.")) + (write-file-tree "foo" port + #:file-type+size + (lambda _ + (values 'regular + (string-length content))) + #:file-port + (lambda _ + (open-input-string content))) + (close-port port) + (bytevector->nix-base32-string (get-hash))) + "\n") + + ;; Arrange so the actual data hash does not match the 'NarHash' field in the + ;; narinfo. + (with-output-to-string + (lambda () + (let ((narinfo (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) " +NarSize: 42 +References: +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n"))) + (with-narinfo (string-append narinfo "Signature: " + (signature-field narinfo) "\n") + (call-with-temporary-directory + (lambda (directory) + (with-input-from-string (string-append + "substitute " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash " + directory "/wrong-hash\n") + (lambda () + (guix-substitute "--substitute")))))))))) + (test-quit "substitute, unauthorized key" "no valid substitute" (with-narinfo (string-append %narinfo "Signature: " -- cgit v1.2.3 From 77a1efed9e12ce0e2c470d7b0601ae70c72b010b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Dec 2020 14:33:06 +0100 Subject: tests: Check the mtime and permissions of substituted items. * tests/store.scm ("substitute") ("substitute + build-things with output path") ("substitute + build-things with specific output"): Call 'canonical-file?'. * tests/substitute.scm ("substitute, authorized key"): Check the mtime and permissions of "substitute-retrieved". --- tests/store.scm | 3 +++ tests/substitute.scm | 6 ++++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 7f1ec51875..4dc125bcb9 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -715,6 +715,7 @@ #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-derivations s (list d)) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute + build-things with output path" @@ -735,6 +736,7 @@ (and (has-substitutes? s o) (build-things s (list o)) ;give the output path (valid-path? s o) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute + build-things with specific output" @@ -755,6 +757,7 @@ (build-things s `((,(derivation-file-name d) . "out"))) (valid-path? s o) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute, corrupt output hash" diff --git a/tests/substitute.scm b/tests/substitute.scm index 5b42632552..542aaf603f 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -378,7 +378,7 @@ System: mips64el-linux\n"))) (guix-substitute "--substitute"))))) (test-equal "substitute, authorized key" - "Substitutable data." + '("Substitutable data." 1 #o444) (with-narinfo (string-append %narinfo "Signature: " (signature-field %narinfo)) (dynamic-wind @@ -387,7 +387,9 @@ System: mips64el-linux\n"))) (request-substitution (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") "substitute-retrieved") - (call-with-input-file "substitute-retrieved" get-string-all)) + (list (call-with-input-file "substitute-retrieved" get-string-all) + (stat:mtime (lstat "substitute-retrieved")) + (stat:perms (lstat "substitute-retrieved")))) (lambda () (false-if-exception (delete-file "substitute-retrieved")))))) -- cgit v1.2.3 From 3c799ccb98ba2ea4c19747306289586e42ae493b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Dec 2020 15:33:00 +0100 Subject: tests: Make sure substituted items are deduplicated. * tests/store.scm ("substitute, deduplication"): New test. --- tests/store.scm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 4dc125bcb9..c9a08ac690 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -718,6 +718,30 @@ (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) +(test-assert "substitute, deduplication" + (with-store s + (let* ((c (random-text)) ; contents of the output + (g (package-derivation s %bootstrap-guile)) + (d1 (build-expression->derivation s "substitute-me" + `(begin ,c (exit 1)) + #:guile-for-build g)) + (d2 (build-expression->derivation s "build-me" + `(call-with-output-file %output + (lambda (p) + (display ,c p))) + #:guile-for-build g)) + (o1 (derivation->output-path d1)) + (o2 (derivation->output-path d2))) + (with-derivation-substitute d1 c + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? s o1) + (build-derivations s (list d2)) ;build + (build-derivations s (list d1)) ;substitute + (canonical-file? o1) + (equal? c (call-with-input-file o1 get-string-all)) + (= (stat:ino (stat o1)) (stat:ino (stat o2)))))))) + (test-assert "substitute + build-things with output path" (with-store s (let* ((c (random-text)) ;contents of the output -- cgit v1.2.3 From 9608f4003dedd8dfe99327c15668ca1a43ebd93b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Dec 2020 11:44:19 +0100 Subject: tests: Fix malformed JSON. Guile-JSON 4.3.2 would parse in spite of these typos, but 4.4.1 is stricter. * tests/swh.scm (%directory-entries): Add missing comma. * tests/cve-sample.json: Likewise. --- tests/cve-sample.json | 2 +- tests/swh.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/cve-sample.json b/tests/cve-sample.json index 39816f9dd4..11b71817bb 100644 --- a/tests/cve-sample.json +++ b/tests/cve-sample.json @@ -49,7 +49,7 @@ "vulnerable" : true, "cpe23Uri" : "cpe:2.3:o:juniper:junos:16.1:*:*:*:*:*:*:*" } ] - } { + }, { "operator" : "OR", "cpe_match" : [ { "vulnerable" : true, diff --git a/tests/swh.scm b/tests/swh.scm index aef68acbe7..06984b2a80 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -33,7 +33,7 @@ "[ { \"name\": \"one\", \"type\": \"regular\", \"length\": 123, - \"dir_id\": 1 } + \"dir_id\": 1 }, { \"name\": \"two\", \"type\": \"regular\", \"length\": 456, -- cgit v1.2.3 From 527551287011888c2ba13fe92e636300ce625430 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Dec 2020 12:06:11 +0100 Subject: tests: Check the effect of '--without-tests' on implicit inputs. * tests/transformations.scm ("options->transformation, without-tests"): Ensure TAR has #:tests? #f. --- tests/transformations.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/tests/transformations.scm b/tests/transformations.scm index 07ed8b1234..2d33bed7ae 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -368,10 +368,9 @@ (let ((new (t p))) (match (bag-direct-inputs (package->bag new)) ((("dep" dep) ("tar" tar) _ ...) - ;; TODO: Check whether TAR has #:tests? #f when transformations - ;; apply to implicit inputs. - (equal? (package-arguments dep) - '(#:tests? #f))))))) + (and (equal? (package-arguments dep) '(#:tests? #f)) + (match (memq #:tests? (package-arguments tar)) + ((#:tests? #f _ ...) #t)))))))) (test-end) -- cgit v1.2.3 From f00e68ace070fd5240a4b5874e61c26f6e909b6c Mon Sep 17 00:00:00 2001 From: Miguel Ángel Arruga Vivas Date: Mon, 21 Dec 2020 13:02:01 +0100 Subject: system: Allow separated /boot and encrypted root. * gnu/bootloader/grub.scm (grub-configuration-file): New parameter store-crypto-devices. [crypto-devices]: New helper function. [builder]: Use crypto-devices. * gnu/machine/ssh.scm (roll-back-managed-host): Use boot-parameters-store-crypto-devices to provide its contents to the bootloader configuration generation process. * gnu/tests/install.scm (%encrypted-root-not-boot-os, %encrypted-root-not-boot-os): New os declaration. (%encrypted-root-not-boot-installation-script): New script, whose contents were initially taken from %encrypted-root-installation-script. (%test-encrypted-root-not-boot-os): New test. * gnu/system.scm (define-module): Export operating-system-bootoader-crypto-devices and boot-parameters-store-crypto-devices. (): Add field store-crypto-devices. (read-boot-parameters): Parse store-crypto-devices field. [uuid-sexp->uuid]: New helper function extracted from device-sexp->device. (operating-system-bootloader-crypto-devices): New function. (operating-system-bootcfg): Use operating-system-bootloader-crypto-devices to provide its contents to the bootloader configuration generation process. (operating-system-boot-parameters): Add store-crypto-devices to the generated boot-parameters. (operating-system-boot-parameters-file): Likewise to the file with the serialized structure. * guix/scripts/system.scm (reinstall-bootloader): Use boot-parameters-store-crypto-devices to provide its contents to the bootloader configuration generation process. * tests/boot-parameters.scm (%default-store-crypto-devices): New variable. (%grub-boot-parameters, test-read-boot-parameters): Use %default-store-crypto-devices. (tests store-crypto-devices): New tests. --- gnu/bootloader/grub.scm | 21 +++++++++- gnu/machine/ssh.scm | 3 ++ gnu/system.scm | 59 ++++++++++++++++++++++++++- gnu/tests/install.scm | 102 ++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/system.scm | 2 + tests/boot-parameters.scm | 30 +++++++++++++- 6 files changed, 212 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index af7b7561ff..29c81ae641 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2017 Leo Famulari ;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen -;;; Copyright © 2019 Miguel Ángel Arruga Vivas +;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2020 Stefan ;;; @@ -359,11 +359,14 @@ code." (locale #f) (system (%current-system)) (old-entries '()) + (store-crypto-devices '()) store-directory-prefix) "Return the GRUB configuration file corresponding to CONFIG, a object, and where the store is available at STORE-FS, a object. OLD-ENTRIES is taken to be a list of menu entries corresponding to old generations of the system. +STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must +be unlocked to access the store contents. STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required when booting a root file system on a Btrfs subvolume." (define all-entries @@ -411,6 +414,21 @@ menuentry ~s { (string-join (map string-join '#$modules) "\n module " 'prefix)))))) + (define (crypto-devices) + (define (crypto-device->cryptomount dev) + (if (uuid? dev) + #~(format port "cryptomount -u ~a~%" + ;; cryptomount only accepts UUID without the hypen. + #$(string-delete #\- (uuid->string dev))) + ;; Other type of devices aren't implemented. + #~())) + (let ((devices (map crypto-device->cryptomount store-crypto-devices)) + ;; XXX: Add luks2 when grub 2.06 is packaged. + (modules #~(format port "insmod luks~%"))) + (if (null? devices) + devices + (cons modules devices)))) + (define (sugar) (let* ((entry (first all-entries)) (device (menu-entry-device entry)) @@ -474,6 +492,7 @@ keymap ~a~%" #$keymap)))) "# This file was generated from your Guix configuration. Any changes # will be lost upon reconfiguration. ") + #$@(crypto-devices) #$(sugar) #$locale-config #$keyboard-layout-config diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 1b748c8da7..08c653ba17 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -484,6 +484,8 @@ an environment type of 'managed-host." (list (second boot-parameters)))) (locale -> (boot-parameters-locale (second boot-parameters))) + (crypto-dev -> (boot-parameters-store-crypto-devices + (second boot-parameters))) (store-dir -> (boot-parameters-store-directory-prefix (second boot-parameters))) (old-entries -> (map boot-parameters->menu-entry @@ -496,6 +498,7 @@ an environment type of 'managed-host." bootloader)) bootloader entries #:locale locale + #:store-crypto-devices crypto-dev #:store-directory-prefix store-dir #:old-entries old-entries))) (remote-result (machine-remote-eval machine remote-exp))) diff --git a/gnu/system.scm b/gnu/system.scm index fcf3310fa3..c284a18379 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Meiyo Peng -;;; Copyright © 2019 Miguel Ángel Arruga Vivas +;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas ;;; Copyright © 2020 Danny Milosavljevic ;;; Copyright © 2020 Brice Waegeneire ;;; Copyright © 2020 Florian Pelz @@ -112,6 +112,7 @@ operating-system-store-file-system operating-system-user-mapped-devices operating-system-boot-mapped-devices + operating-system-bootloader-crypto-devices operating-system-activation-script operating-system-user-accounts operating-system-shepherd-service-names @@ -147,6 +148,7 @@ boot-parameters-root-device boot-parameters-bootloader-name boot-parameters-bootloader-menu-entries + boot-parameters-store-crypto-devices boot-parameters-store-device boot-parameters-store-directory-prefix boot-parameters-store-mount-point @@ -305,6 +307,8 @@ directly by the user." (store-device boot-parameters-store-device) (store-mount-point boot-parameters-store-mount-point) (store-directory-prefix boot-parameters-store-directory-prefix) + (store-crypto-devices boot-parameters-store-crypto-devices + (default '())) (locale boot-parameters-locale) (kernel boot-parameters-kernel) (kernel-arguments boot-parameters-kernel-arguments) @@ -338,6 +342,13 @@ file system labels." (if (string-prefix? "/" device) device (file-system-label device)))))) + (define uuid-sexp->uuid + (match-lambda + (('uuid (? symbol? type) (? bytevector? bv)) + (bytevector->uuid bv type)) + (x + (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port)) + #f))) (match (read port) (('boot-parameters ('version 0) @@ -411,6 +422,23 @@ file system labels." ;; No store found, old format. #f))) + (store-crypto-devices + (match (assq 'store rest) + (('store . store-data) + (match (assq 'crypto-devices store-data) + (('crypto-devices (devices ...)) + (map uuid-sexp->uuid devices)) + (('crypto-devices dev) + (warning (G_ "unrecognized crypto-devices ~S at '~a'~%") + dev (port-filename port)) + '()) + (_ + ;; No crypto-devices found. + '()))) + (_ + ;; No store found, old format. + '()))) + (store-mount-point (match (assq 'store rest) (('store ('device _) ('mount-point mount-point) _ ...) @@ -525,6 +553,26 @@ from the initrd." (any file-system-needed-for-boot? users))) devices))) +(define (operating-system-bootloader-crypto-devices os) + "Return the subset of mapped devices that the bootloader must open. +Only devices specified by uuid are supported." + (define (valid-crypto-device? dev) + (or (uuid? dev) + (begin + (warning (G_ "\ +mapped-device '~a' may not be mounted by the bootloader.~%") + dev) + #f))) + (filter-map (match-lambda + ((and (= mapped-device-type type) + (= mapped-device-source source)) + (and (eq? luks-device-mapping type) + (valid-crypto-device? source) + source)) + (_ #f)) + ;; XXX: Ordering is important, we trust the returned one. + (operating-system-boot-mapped-devices os))) + (define (device-mapping-services os) "Return the list of device-mapping services for OS as a list." (map device-mapping-service @@ -1261,6 +1309,7 @@ a list of , to populate the \"old entries\" menu." (root-fs (operating-system-root-file-system os)) (root-device (file-system-device root-fs)) (locale (operating-system-locale os)) + (crypto-devices (operating-system-bootloader-crypto-devices os)) (params (operating-system-boot-parameters os root-device #:system-kernel-arguments? #t)) @@ -1274,6 +1323,7 @@ a list of , to populate the \"old entries\" menu." (generate-config-file bootloader-conf (list entry) #:old-entries old-entries #:locale locale + #:store-crypto-devices crypto-devices #:store-directory-prefix (btrfs-store-subvolume-file-name file-systems)))) @@ -1313,6 +1363,7 @@ such as '--root' and '--load' to ." (operating-system-initrd-file os))) (store (operating-system-store-file-system os)) (file-systems (operating-system-file-systems os)) + (crypto-devices (operating-system-bootloader-crypto-devices os)) (locale (operating-system-locale os)) (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os))) @@ -1335,6 +1386,7 @@ such as '--root' and '--load' to ." (locale locale) (store-device (ensure-not-/dev (file-system-device store))) (store-directory-prefix (btrfs-store-subvolume-file-name file-systems)) + (store-crypto-devices crypto-devices) (store-mount-point (file-system-mount-point store))))) (define (device->sexp device) @@ -1393,7 +1445,10 @@ being stored into the \"parameters\" file)." (mount-point #$(boot-parameters-store-mount-point params)) (directory-prefix - #$(boot-parameters-store-directory-prefix params)))) + #$(boot-parameters-store-directory-prefix params)) + (crypto-devices + #$(map device->sexp + (boot-parameters-store-crypto-devices params))))) #:set-load-path? #f))) (define-gexp-compiler (operating-system-compiler (os ) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 71caa3a493..bf94e97c2a 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -63,6 +63,7 @@ %test-separate-home-os %test-raid-root-os %test-encrypted-root-os + %test-encrypted-root-not-boot-os %test-btrfs-root-os %test-btrfs-root-on-subvolume-os %test-jfs-root-os @@ -883,6 +884,107 @@ reboot\n") (run-basic-test %lvm-separate-home-os `(,@command) "lvm-separate-home-os"))))) + +;;; +;;; LUKS-encrypted root file system and /boot in a non-encrypted partition. +;;; + +(define-os-with-source (%encrypted-root-not-boot-os + %encrypted-root-not-boot-os-source) + ;; The OS we want to install. + (use-modules (gnu) (gnu tests) (srfi srfi-1)) + + (operating-system + (host-name "bootroot") + (timezone "Europe/Madrid") + (locale "en_US.UTF-8") + + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vdb"))) + + (mapped-devices (list (mapped-device + (source + (uuid "12345678-1234-1234-1234-123456789abc")) + (target "root") + (type luks-device-mapping)))) + (file-systems (cons* (file-system + (device (file-system-label "my-boot")) + (mount-point "/boot") + (type "ext4")) + (file-system + (device "/dev/mapper/root") + (mount-point "/") + (type "ext4")) + %base-file-systems)) + (users (cons (user-account + (name "alice") + (group "users") + (supplementary-groups '("wheel" "audio" "video"))) + %base-user-accounts)) + (services (cons (service marionette-service-type + (marionette-configuration + (imported-modules '((gnu services herd) + (guix combinators))))) + %base-services)))) + +(define %encrypted-root-not-boot-installation-script + ;; Shell script for an installation with boot not encrypted but root + ;; encrypted. + (format #f "\ +. /etc/profile +set -e -x +guix --version + +export GUIX_BUILD_OPTIONS=--no-grafts +ls -l /run/current-system/gc-roots +parted --script /dev/vdb mklabel gpt \\ + mkpart primary ext2 1M 3M \\ + mkpart primary ext2 3M 50M \\ + mkpart primary ext2 50M 1.6G \\ + set 1 boot on \\ + set 1 bios_grub on +echo -n \"~a\" | cryptsetup luksFormat --uuid=\"~a\" -q /dev/vdb3 - +echo -n \"~a\" | cryptsetup open --type luks --key-file - /dev/vdb3 root +mkfs.ext4 -L my-root /dev/mapper/root +mkfs.ext4 -L my-boot /dev/vdb2 +mount LABEL=my-root /mnt +mkdir /mnt/boot +mount LABEL=my-boot /mnt/boot +echo \"Checking mounts\" +mount +herd start cow-store /mnt +mkdir /mnt/etc +cp /etc/target-config.scm /mnt/etc/config.scm +guix system build /mnt/etc/config.scm +guix system init /mnt/etc/config.scm /mnt --no-substitutes +sync +echo \"Debugging info\" +blkid +cat /mnt/boot/grub/grub.cfg +reboot\n" + %luks-passphrase "12345678-1234-1234-1234-123456789abc" + %luks-passphrase)) + +(define %test-encrypted-root-not-boot-os + (system-test + (name "encrypted-root-not-boot-os") + (description + "Test the manual installation on an OS with / in an encrypted partition +but /boot on a different, non-encrypted partition. This test is expensive in +terms of CPU and storage usage since we need to build (current-guix) and then +store a couple of full system images.") + (value + (mlet* %store-monad + ((image (run-install %encrypted-root-not-boot-os + %encrypted-root-not-boot-os-source + #:script + %encrypted-root-not-boot-installation-script)) + (command (qemu-command/writable-image image))) + (run-basic-test %encrypted-root-not-boot-os command + "encrypted-root-not-boot-os" + #:initialization enter-luks-passphrase))))) + ;;; ;;; Btrfs root file system. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5427f875ec..0dcf2b3afe 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -391,6 +391,7 @@ STORE is an open connection to the store." (params (first (profile-boot-parameters %system-profile (list number)))) (locale (boot-parameters-locale params)) + (store-crypto-devices (boot-parameters-store-crypto-devices params)) (store-directory-prefix (boot-parameters-store-directory-prefix params)) (old-generations @@ -406,6 +407,7 @@ STORE is an open connection to the store." ((bootloader-configuration-file-generator bootloader) bootloader-config entries #:locale locale + #:store-crypto-devices store-crypto-devices #:store-directory-prefix store-directory-prefix #:old-entries old-entries))) (drvs -> (list bootcfg))) diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm index a00b227551..3deae564c4 100644 --- a/tests/boot-parameters.scm +++ b/tests/boot-parameters.scm @@ -50,6 +50,9 @@ (define %default-store-directory-prefix (string-append "/" %default-btrfs-subvolume)) (define %default-store-mount-point (%store-prefix)) +(define %default-store-crypto-devices + (list (uuid "00000000-1111-2222-3333-444444444444") + (uuid "55555555-6666-7777-8888-999999999999"))) (define %default-multiboot-modules '()) (define %default-locale "es_ES.utf8") (define %root-path "/") @@ -67,6 +70,7 @@ (locale %default-locale) (store-device %default-store-device) (store-directory-prefix %default-store-directory-prefix) + (store-crypto-devices %default-store-crypto-devices) (store-mount-point %default-store-mount-point))) (define %default-operating-system @@ -110,6 +114,8 @@ (with-store #t) (store-device (quote-uuid %default-store-device)) + (store-crypto-devices + (map quote-uuid %default-store-crypto-devices)) (store-directory-prefix %default-store-directory-prefix) (store-mount-point %default-store-mount-point)) (define (generate-boot-parameters) @@ -125,12 +131,14 @@ (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments) (sexp-or-nothing " (initrd ~S)" initrd) (if with-store - (format #false " (store~a~a~a)" + (format #false " (store~a~a~a~a)" (sexp-or-nothing " (device ~S)" store-device) (sexp-or-nothing " (mount-point ~S)" store-mount-point) (sexp-or-nothing " (directory-prefix ~S)" - store-directory-prefix)) + store-directory-prefix) + (sexp-or-nothing " (crypto-devices ~S)" + store-crypto-devices)) "") (sexp-or-nothing " (locale ~S)" locale) (sexp-or-nothing " (bootloader-name ~a)" bootloader-name) @@ -158,6 +166,7 @@ (test-read-boot-parameters #:with-store #false) (test-read-boot-parameters #:store-device #false) (test-read-boot-parameters #:store-device 'false) + (test-read-boot-parameters #:store-crypto-devices #false) (test-read-boot-parameters #:store-mount-point #false) (test-read-boot-parameters #:store-directory-prefix #false) (test-read-boot-parameters #:multiboot-modules #false) @@ -254,6 +263,23 @@ (boot-parameters-store-mount-point (test-read-boot-parameters #:with-store #false))) +(test-equal "read, store-crypto-devices, default" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices #false))) + +;; XXX: +(test-equal "read, store-crypto-devices, false" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices 'false))) + +;; XXX: +(test-equal "read, store-crypto-devices, string" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices "bad"))) + ;; For whitebox testing (define operating-system-boot-parameters (@@ (gnu system) operating-system-boot-parameters)) -- cgit v1.2.3