From e9edaf3639ecf9d4fdaf7901d60a87c582be1c44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2020 22:32:04 +0100 Subject: database: Remove unnecessary module imports. * guix/store/database.scm: Remove unnecessary imports added in 4b9eecd322e566783369795ebea63a479b51f486. --- guix/store/database.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix/store') diff --git a/guix/store/database.scm b/guix/store/database.scm index 2ea63b17aa..b36b127630 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,7 +21,6 @@ (define-module (guix store database) #:use-module (sqlite3) #:use-module (guix config) - #:use-module (guix gexp) #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) @@ -29,7 +28,6 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) - #:use-module (guix utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) -- 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 'guix/store') 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 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 'guix/store') 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 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 'guix/store') 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 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 'guix/store') 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 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 'guix/store') 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 1574bd82bb36ee64574912c3e8855f94a73adc44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Dec 2020 12:36:52 +0100 Subject: system: 'init' does not recompute the hash of each store item. Fixes . Previously, the 'register-path' call would re-traverse ITEM to compute its nar hash, even though that hash is already known in the initial store. This patch also avoids repeated opening/closing of the database. * guix/store/database.scm (call-with-database): Export. * guix/scripts/system.scm (copy-item): Add 'db' parameter. Call 'sqlite-register' instead of 'register-path'. (copy-closure): Remove redundant call to 'references*'. Call 'call-with-database' and pass the database to 'copy-item'. --- .dir-locals.el | 1 + guix/scripts/system.scm | 59 +++++++++++++++++++++++++++---------------------- guix/store/database.scm | 1 + 3 files changed, 34 insertions(+), 27 deletions(-) (limited to 'guix/store') diff --git a/.dir-locals.el b/.dir-locals.el index 4eb27d8b1b..8f07a08eb5 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -121,6 +121,7 @@ (eval . (put 'let-system 'scheme-indent-function 1)) (eval . (put 'with-database 'scheme-indent-function 2)) + (eval . (put 'call-with-database 'scheme-indent-function 1)) (eval . (put 'call-with-transaction 'scheme-indent-function 1)) (eval . (put 'with-statement 'scheme-indent-function 3)) (eval . (put 'call-with-retrying-transaction 'scheme-indent-function 1)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0e543d9460..5427f875ec 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -29,7 +29,9 @@ #:use-module (guix ui) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) - #:autoload (guix store database) (register-path) + #:autoload (guix base16) (bytevector->base16-string) + #:autoload (guix store database) + (sqlite-register store-database-file call-with-database) #:autoload (guix build store-copy) (copy-store-item) #:use-module (guix describe) #:use-module (guix grafts) @@ -130,12 +132,11 @@ BODY..., and restore them." (store-lift topologically-sorted)) -(define* (copy-item item references target +(define* (copy-item item info target db #:key (log-port (current-error-port))) - "Copy ITEM to the store under root directory TARGET and register it with -REFERENCES as its set of references." - (let ((dest (string-append target item)) - (state (string-append target "/var/guix"))) + "Copy ITEM to the store under root directory TARGET and populate DB with the +given INFO, a record." + (let ((dest (string-append target item))) (format log-port "copying '~a'...~%" item) ;; Remove DEST if it exists to make sure that (1) we do not fail badly @@ -151,41 +152,45 @@ REFERENCES as its set of references." (copy-store-item item target #:deduplicate? #t) - ;; Register ITEM; as a side-effect, it resets timestamps, etc. - ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid - ;; reproducing the user's current settings; see - ;; . - (unless (register-path item - #:prefix target - #:state-directory state - #:references references) - (leave (G_ "failed to register '~a' under '~a'~%") - item target)))) + (sqlite-register db + #:path item + #:references (path-info-references info) + #:deriver (path-info-deriver info) + #:hash (string-append + "sha256:" + (bytevector->base16-string (path-info-hash info))) + #:nar-size (path-info-nar-size info)))) (define* (copy-closure item target #:key (log-port (current-error-port))) "Copy ITEM and all its dependencies to the store under root directory TARGET, and register them." (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) - (refs (mapm %store-monad references* to-copy)) - (info (mapm %store-monad query-path-info* - (delete-duplicates - (append to-copy (concatenate refs))))) + (info (mapm %store-monad query-path-info* to-copy)) (size -> (reduce + 0 (map path-info-nar-size info)))) (define progress-bar (progress-reporter/bar (length to-copy) (format #f (G_ "copying to '~a'...") target))) + (define state + (string-append target "/var/guix")) + (check-available-space size target) - (call-with-progress-reporter progress-bar - (lambda (report) - (let ((void (%make-void-port "w"))) - (for-each (lambda (item refs) - (copy-item item refs target #:log-port void) - (report)) - to-copy refs)))) + ;; Explicitly use "TARGET/var/guix" as the state directory to avoid + ;; reproducing the user's current settings; see + ;; . + (call-with-database (store-database-file #:prefix target + #:state-directory state) + (lambda (db) + (call-with-progress-reporter progress-bar + (lambda (report) + (let ((void (%make-void-port "w"))) + (for-each (lambda (item info) + (copy-item item info target db #:log-port void) + (report)) + to-copy info)))))) (return *unspecified*))) diff --git a/guix/store/database.scm b/guix/store/database.scm index c0010b72b9..9d5bc531bb 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -39,6 +39,7 @@ #:export (sql-schema %default-database-file store-database-file + call-with-database with-database path-id sqlite-register -- 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 'guix/store') 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 9e6fe0e08fda67ab298ca33ef00ffbf078ce4dd9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Dec 2020 15:37:20 +0100 Subject: database: Honor 'SOURCE_DATE_EPOCH'. * guix/store/database.scm (timestamp): New procedure. (sqlite-register): Use it as the default for #:time. (register-items): Likewise for #:registeration-time. --- guix/store/database.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'guix/store') diff --git a/guix/store/database.scm b/guix/store/database.scm index 4579b05261..0a84bbddb9 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -323,8 +323,19 @@ ids of items referred to." (sqlite-fold cons '() stmt)) references))) +(define (timestamp) + "Return a timestamp, either the current time of SOURCE_DATE_EPOCH." + (match (getenv "SOURCE_DATE_EPOCH") + (#f + (current-time time-utc)) + ((= string->number seconds) + (if seconds + (make-time time-utc 0 seconds) + (current-time time-utc))))) + (define* (sqlite-register db #:key path (references '()) - deriver hash nar-size time) + deriver hash nar-size + (time (timestamp))) "Registers this stuff in DB. PATH is the store item to register and REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' that produced PATH, HASH is the base16-encoded Nix sha256 hash of @@ -337,9 +348,7 @@ Every store item in REFERENCES must already be registered." #:deriver deriver #:hash hash #:nar-size nar-size - #:time (time-second - (or time - (current-time time-utc)))))) + #:time (time-second time)))) ;; Call 'path-id' on each of REFERENCES. This ensures we get a ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. (add-references db id @@ -388,7 +397,7 @@ is true." (define* (register-items db items #:key prefix - registration-time + (registration-time (timestamp)) (log-port (current-error-port))) "Register all of ITEMS, a list of records as returned by 'read-reference-graph', in DB. ITEMS must be in topological order (with -- 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 'guix/store') 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 4f621a2b003e85d480999e4d0630e9dc3de85bc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Dec 2020 16:19:07 +0100 Subject: maint: Require Guile >= 2.2.6. * configure.ac: For Guile 2.2, require 2.2.6 or later. * guix/gexp.scm (define-syntax-parameter-once): Remove. Use 'define-syntax-parameter' instead. * guix/mnoads.scm: Likewise. * guix/inferior.scm (proxy)[select*]: Remove. * guix/scripts/publish.scm : Remove replacement for (@@ (web http) read-header-line). * guix/store/deduplication.scm (counting-wrapper-port): Remove. (nar-sha256): Call 'port-position' on PORT to compute SIZE. --- configure.ac | 2 +- guix/gexp.scm | 15 ++------------- guix/inferior.scm | 11 +---------- guix/monads.scm | 15 ++------------- guix/scripts/publish.scm | 26 -------------------------- guix/store/deduplication.scm | 32 ++++---------------------------- 6 files changed, 10 insertions(+), 91 deletions(-) (limited to 'guix/store') diff --git a/configure.ac b/configure.ac index a5bdf24e93..afb449950f 100644 --- a/configure.ac +++ b/configure.ac @@ -102,7 +102,7 @@ if test "x$GUILD" = "x"; then fi if test "x$GUILE_EFFECTIVE_VERSION" = "x2.2"; then - PKG_CHECK_MODULES([GUILE], [guile-2.2 >= 2.2.3]) + PKG_CHECK_MODULES([GUILE], [guile-2.2 >= 2.2.6]) fi dnl Get CFLAGS and LDFLAGS for libguile. diff --git a/guix/gexp.scm b/guix/gexp.scm index 051831238e..764c89a187 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1317,18 +1317,7 @@ and in the current monad setting (system type, etc.)" reference->sexp (gexp-references exp)))) (return (apply (gexp-proc exp) args)))) -(define-syntax-rule (define-syntax-parameter-once name proc) - ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME - ;; does not get redefined. This works around a race condition in a - ;; multi-threaded context with Guile <= 2.2.4: . - (eval-when (load eval expand compile) - (define name - (if (module-locally-bound? (current-module) 'name) - (module-ref (current-module) 'name) - (make-syntax-transformer 'name 'syntax-parameter - (list proc)))))) - -(define-syntax-parameter-once current-imported-modules +(define-syntax-parameter current-imported-modules ;; Current list of imported modules. (identifier-syntax '())) @@ -1339,7 +1328,7 @@ environment." (identifier-syntax modules))) body ...)) -(define-syntax-parameter-once current-imported-extensions +(define-syntax-parameter current-imported-extensions ;; Current list of extensions. (identifier-syntax '())) diff --git a/guix/inferior.scm b/guix/inferior.scm index 77820872b3..2fe91beaab 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -469,22 +469,13 @@ is similar to the sexp returned by 'package-provenance' for regular packages." "Proxy communication between CLIENT and BACKEND until CLIENT closes the connection, at which point CLIENT is closed (both CLIENT and BACKEND must be input/output ports.)" - (define (select* read write except) - ;; This is a workaround for in Guile < 2.2.4: - ;; since 'select' sometimes returns non-empty sets for no good reason, - ;; call 'select' a second time with a zero timeout to filter out incorrect - ;; replies. - (match (select read write except) - ((read write except) - (select read write except 0)))) - ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see . (setvbuf client 'block 65536) (setvbuf backend 'block 65536) (let loop () - (match (select* (list client backend) '() '()) + (match (select (list client backend) '() '()) ((reads () ()) (when (memq client reads) (match (get-bytevector-some client) diff --git a/guix/monads.scm b/guix/monads.scm index 6924471345..6ae616aca9 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -274,23 +274,12 @@ more optimizations." (_ #'generic-name)))))))))) -(define-syntax-rule (define-syntax-parameter-once name proc) - ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME - ;; does not get redefined. This works around a race condition in a - ;; multi-threaded context with Guile <= 2.2.4: . - (eval-when (load eval expand compile) - (define name - (if (module-locally-bound? (current-module) 'name) - (module-ref (current-module) 'name) - (make-syntax-transformer 'name 'syntax-parameter - (list proc)))))) - -(define-syntax-parameter-once >>= +(define-syntax-parameter >>= ;; The name 'bind' is already taken, so we choose this (obscure) symbol. (lambda (s) (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) -(define-syntax-parameter-once return +(define-syntax-parameter return (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c31cef3181..5a865c838d 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -824,32 +824,6 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define %http-write (@@ (web server http) http-write)) -(match (list (major-version) (minor-version) (micro-version)) - (("2" "2" "5") ;Guile 2.2.5 - (let () - (define %read-line (@ (ice-9 rdelim) %read-line)) - (define bad-header (@@ (web http) bad-header)) - - ;; XXX: Work around by reverting to the - ;; definition of 'read-header-line' as found in 2.2.4 and earlier. - (define (read-header-line port) - "Read an HTTP header line and return it without its final CRLF or LF. -Raise a 'bad-header' exception if the line does not end in CRLF or LF, -or if EOF is reached." - (match (%read-line port) - (((? string? line) . #\newline) - ;; '%read-line' does not consider #\return a delimiter; so if it's - ;; there, remove it. We are more tolerant than the RFC in that we - ;; tolerate LF-only endings. - (if (string-suffix? "\r" line) - (string-drop-right line 1) - line)) - ((line . _) ;EOF or missing delimiter - (bad-header 'read-header-line line)))) - - (set! (@@ (web http) read-header-line) read-header-line))) - (_ #t)) - (define (strip-headers response) "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a72a43bf79..cd9660174c 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -37,38 +37,14 @@ 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 -;; equal to 2^32: . -(define (counting-wrapper-port output-port) - "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to -retrieve the number of bytes written to OUTPUT-PORT." - (let ((byte-count 0)) - (values (make-custom-binary-output-port "counting-wrapper" - (lambda (bytes offset count) - (put-bytevector output-port bytes - offset count) - (set! byte-count - (+ byte-count count)) - count) - (lambda () - byte-count) - #f - (lambda () - (close-port output-port))) - (lambda () - byte-count)))) - (define (nar-sha256 file) "Gives the sha256 hash of a file and the size of the file in nar form." - (let*-values (((port get-hash) (open-sha256-port)) - ((wrapper get-size) (counting-wrapper-port port))) - (write-file file wrapper) - (force-output wrapper) + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port) (force-output port) (let ((hash (get-hash)) - (size (get-size))) - (close-port wrapper) + (size (port-position port))) + (close-port port) (values hash size)))) (define (tempname-in directory) -- cgit v1.2.3