From 9cf531f57786c858c34c11a08b0ad16e2f26b27b Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Thu, 3 Dec 2020 12:11:00 +0100 Subject: images: Add novena-image-type, novena-barebones-raw-image, novena-barebones-os. * gnu/system/images/novena.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/system/images/novena.scm | 67 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 gnu/system/images/novena.scm (limited to 'gnu/system') diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm new file mode 100644 index 0000000000..335074e3b7 --- /dev/null +++ b/gnu/system/images/novena.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; Copyright © 2020 Danny Milosavljevic +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu system images novena) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader u-boot) + #:use-module (gnu image) + #:use-module (gnu packages linux) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system image) + #:use-module (srfi srfi-26) + #:export (novena-barebones-os + novena-image-type + novena-barebones-raw-image)) + +(define novena-barebones-os + (operating-system + (host-name "vignemale") + (timezone "Europe/Paris") + (locale "en_US.utf8") + (bootloader (bootloader-configuration + (bootloader u-boot-novena-bootloader) + (target "/dev/vda"))) + (initrd-modules '("sdhci-esdhc-imx" "ahci_imx")) + ;(kernel linux-libre-arm-generic) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + (services (cons (service agetty-service-type + (agetty-configuration + (extra-options '("-L")) ; no carrier detect + (baud-rate "115200") + (term "vt100") + (tty "ttymxc1"))) + %base-services)))) + +(define novena-image-type + (image-type + (name 'novena-raw) + (constructor (cut image-with-os arm32-disk-image <>)))) + +(define novena-barebones-raw-image + (image + (inherit + (os->image novena-barebones-os #:type novena-image-type)) + (name 'novena-barebones-raw-image))) -- cgit v1.2.3 From 295aa49ec996ce46ea1fe6a3929a9b74e8680569 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Thu, 3 Dec 2020 12:24:36 +0100 Subject: images: novena: Replace agetty-service by term-auto. * gnu/system/images/novena.scm (novena-barebones-os)[kernel-arguments]: New field. [services]: Remove field. --- gnu/system/images/novena.scm | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm index 335074e3b7..47780612bc 100644 --- a/gnu/system/images/novena.scm +++ b/gnu/system/images/novena.scm @@ -42,18 +42,12 @@ (target "/dev/vda"))) (initrd-modules '("sdhci-esdhc-imx" "ahci_imx")) ;(kernel linux-libre-arm-generic) + (kernel-arguments '("console=ttymxc1,115200")) (file-systems (cons (file-system (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) - %base-file-systems)) - (services (cons (service agetty-service-type - (agetty-configuration - (extra-options '("-L")) ; no carrier detect - (baud-rate "115200") - (term "vt100") - (tty "ttymxc1"))) - %base-services)))) + %base-file-systems)))) (define novena-image-type (image-type -- cgit v1.2.3 From 83de7ee662fd42cce410dd8c395922647f3aeb13 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 4 Dec 2020 12:36:35 +0100 Subject: image: Fix ISO image production. This is a follow-up of 41f27bf8702838f19b1dc5ffee8eec1d4315d4e6. * gnu/system/image.scm (operating-system-for-image): Force "volatile-root?" to true when producing ISO images. --- gnu/system/image.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 4972d9067b..67930750d5 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -560,7 +560,9 @@ to OS. Also set the UUID and the size of the root partition." "Return an operating-system based on the one specified in IMAGE, but suitable for image creation. Assign an UUID to the root file-system, so that it can be used for bootloading." - (define volatile-root? (image-volatile-root? image)) + (define volatile-root? (if (eq? (image-format image) 'iso9660) + #t + (image-volatile-root? image))) (define (root-uuid os) ;; UUID of the root file system, computed in a deterministic fashion. -- cgit v1.2.3 From 005609c1717ead0c16ad6fba1577b0305df9f1a9 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Sat, 5 Dec 2020 11:18:22 +0100 Subject: images: novena: Make boot settings and RTC accessible. * gnu/system/images/novena.scm (novena-barebones-os)[initrd-modules]: Add i2c-dev. --- gnu/system/images/novena.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm index 47780612bc..c4d25e850e 100644 --- a/gnu/system/images/novena.scm +++ b/gnu/system/images/novena.scm @@ -40,7 +40,7 @@ (bootloader (bootloader-configuration (bootloader u-boot-novena-bootloader) (target "/dev/vda"))) - (initrd-modules '("sdhci-esdhc-imx" "ahci_imx")) + (initrd-modules '("sdhci-esdhc-imx" "ahci_imx" "i2c-dev")) ;(kernel linux-libre-arm-generic) (kernel-arguments '("console=ttymxc1,115200")) (file-systems (cons (file-system -- cgit v1.2.3 From 10defc57bf342d9f093c6a84ec1c3c818057c27d Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Thu, 5 Nov 2020 22:06:24 +0100 Subject: linux-initrd: Add bcachefs support. * gnu/system/linux-initrd.scm (file-system-packages): Add bcachefs-tools/static. (file-system-type-modules): Add an entry for the "bcachefs" type and module. --- gnu/system/linux-initrd.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 85e493fecb..4fb1d863c9 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2016 Mark H Weaver ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; Copyright © 2017, 2019 Mathieu Othacehe -;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -260,6 +260,9 @@ FILE-SYSTEMS." file-systems) (list fatfsck/static) '()) + ,@(if (find (file-system-type-predicate "bcachefs") file-systems) + (list bcachefs-tools/static) + '()) ,@(if (find (file-system-type-predicate "btrfs") file-systems) (list btrfs-progs/static) '()) @@ -295,6 +298,7 @@ FILE-SYSTEMS." ;; Given a file system type, return the list of modules it needs. (lookup-procedure ("cifs" => '("md4" "ecb" "cifs")) ("9p" => '("9p" "9pnet_virtio")) + ("bcachefs" => '("bcachefs")) ("btrfs" => '("btrfs")) ("iso9660" => '("isofs")) ("jfs" => '("jfs")) -- cgit v1.2.3 From 8361817bf693742757b096468198626f297bb09e Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 4 Dec 2020 11:33:16 +0100 Subject: install: Discover local substitute servers. * gnu/installer/substitutes.scm: New file. * gnu/installer/newt/substitutes.scm: New file. * gnu/local.mk (INSTALLER_MODULES): Add them. * po/guix/POTFILES.in: Add gnu/installer/newt/substitutes.scm. * gnu/installer/proxy.scm (with-silent-shepherd): Move to ... * gnu/installer/utils.scm: ... here. * gnu/installer/record.scm ()[substitutes-page]: New field. * gnu/installer/newt.scm (substitutes-page): New procedure, (newt-installer): register it. * gnu/installer.scm (installer-steps): Add "substitutes-page" step. * gnu/system/install.scm (%installation-services): Add avahi-service-type and enable substitute server discover in guix-service-type. []: Set it to %mdns-host-lookup-nss. --- gnu/installer.scm | 7 +++++++ gnu/installer/newt.scm | 5 +++++ gnu/installer/newt/substitutes.scm | 43 ++++++++++++++++++++++++++++++++++++++ gnu/installer/proxy.scm | 6 +----- gnu/installer/record.scm | 3 +++ gnu/installer/substitutes.scm | 41 ++++++++++++++++++++++++++++++++++++ gnu/installer/utils.scm | 11 +++++++++- gnu/local.mk | 2 ++ gnu/system/install.scm | 6 ++++++ po/guix/POTFILES.in | 1 + 10 files changed, 119 insertions(+), 6 deletions(-) create mode 100644 gnu/installer/newt/substitutes.scm create mode 100644 gnu/installer/substitutes.scm (limited to 'gnu/system') diff --git a/gnu/installer.scm b/gnu/installer.scm index f401b242f8..7863edbb67 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -266,6 +266,13 @@ selected keymap." (compute (lambda _ ((installer-network-page current-installer))))) + ;; Ask whether to enable substitute server discovery. + (installer-step + (id 'substitutes) + (description (G_ "Substitute server discovery")) + (compute (lambda _ + ((installer-substitutes-page current-installer))))) + ;; Prompt for users (name, group and home directory). (installer-step (id 'user) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index a1cbeca49a..4f7fc6f4dc 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -30,6 +30,7 @@ #:use-module (gnu installer newt page) #:use-module (gnu installer newt partition) #:use-module (gnu installer newt services) + #:use-module (gnu installer newt substitutes) #:use-module (gnu installer newt timezone) #:use-module (gnu installer newt user) #:use-module (gnu installer newt utils) @@ -101,6 +102,9 @@ problem. The backtrace is displayed below. Please report it by email to \ (define (network-page) (run-network-page)) +(define (substitutes-page) + (run-substitutes-page)) + (define (hostname-page) (run-hostname-page)) @@ -130,6 +134,7 @@ problem. The backtrace is displayed below. Please report it by email to \ (locale-page locale-page) (menu-page menu-page) (network-page network-page) + (substitutes-page substitutes-page) (timezone-page timezone-page) (hostname-page hostname-page) (user-page user-page) diff --git a/gnu/installer/newt/substitutes.scm b/gnu/installer/newt/substitutes.scm new file mode 100644 index 0000000000..938cb1a53b --- /dev/null +++ b/gnu/installer/newt/substitutes.scm @@ -0,0 +1,43 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu installer newt substitutes) + #:use-module (gnu installer substitutes) + #:use-module (gnu installer utils) + #:use-module (guix i18n) + #:use-module (newt) + #:use-module (ice-9 match) + #:export (run-substitutes-page)) + +(define* (run-substitutes-page) + (match (current-clients) + (() + (case (choice-window + (G_ "Substitute server discovery.") + (G_ "Enable") (G_ "Disable") + (G_ " By turning this option on, you allow Guix to fetch \ +substitutes (pre-built binaries) during installation from servers \ +discovered on your local area network (LAN) in addition to the official \ +server. This can increase download throughput. + + There are no security risks: only genuine substitutes may be retrieved from \ +those servers. However, eavesdroppers on your LAN may be able to see what \ +software you are installing.")) + ((1) (enable-discovery)) + ((2) (disable-discovery)))) + (_ #f))) diff --git a/gnu/installer/proxy.scm b/gnu/installer/proxy.scm index befaf3ab0a..86c827294e 100644 --- a/gnu/installer/proxy.scm +++ b/gnu/installer/proxy.scm @@ -17,15 +17,11 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer proxy) + #:use-module (gnu installer utils) #:use-module (gnu services herd) #:export (set-http-proxy clear-http-proxy)) -(define-syntax-rule (with-silent-shepherd exp ...) - (parameterize ((shepherd-message-port - (%make-void-port "w"))) - exp ...)) - (define (set-http-proxy proxy) (with-silent-shepherd (with-shepherd-action 'guix-daemon diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 6ebd87f6a6..0b34318c45 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -33,6 +33,7 @@ installer-locale-page installer-menu-page installer-network-page + installer-substitutes-page installer-timezone-page installer-hostname-page installer-user-page @@ -73,6 +74,8 @@ (menu-page installer-menu-page) ;; procedure void -> void (network-page installer-network-page) + ;; procedure void -> void + (substitutes-page installer-substitutes-page) ;; procedure (zonetab) -> posix-timezone (timezone-page installer-timezone-page) ;; procedure void -> void diff --git a/gnu/installer/substitutes.scm b/gnu/installer/substitutes.scm new file mode 100644 index 0000000000..c9a7418f89 --- /dev/null +++ b/gnu/installer/substitutes.scm @@ -0,0 +1,41 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu installer substitutes) + #:use-module (gnu installer utils) + #:use-module (gnu services herd) + #:export (enable-discovery + disable-discovery)) + +(define (enable-discovery) + (with-silent-shepherd + (with-shepherd-action 'guix-daemon + ('discover "on") + result + result))) + +(define (disable-discovery) + (with-silent-shepherd + (with-shepherd-action 'guix-daemon + ('discover "off") + result + result))) + +;; Local Variables: +;; eval: (put 'with-silent-shepherd 'scheme-indent-function 0) +;; End: diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index a7fa66a199..bb97bc5560 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer utils) + #:use-module (gnu services herd) #:use-module (guix utils) #:use-module (guix build utils) #:use-module (guix i18n) @@ -43,7 +44,9 @@ with-server-socket current-server-socket current-clients - send-to-clients)) + send-to-clients + + with-silent-shepherd)) (define* (read-lines #:optional (port (current-input-port))) "Read lines from PORT and return them as a list." @@ -233,3 +236,9 @@ accepting socket." (current-clients (reverse remainder)) exp) + +(define-syntax-rule (with-silent-shepherd exp ...) + "Evaluate EXP while discarding shepherd messages." + (parameterize ((shepherd-message-port + (%make-void-port "w"))) + exp ...)) diff --git a/gnu/local.mk b/gnu/local.mk index f94725b1e5..4cca7671a8 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -717,6 +717,7 @@ INSTALLER_MODULES = \ %D%/installer/record.scm \ %D%/installer/services.scm \ %D%/installer/steps.scm \ + %D%/installer/substitutes.scm \ %D%/installer/tests.scm \ %D%/installer/timezone.scm \ %D%/installer/user.scm \ @@ -733,6 +734,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/page.scm \ %D%/installer/newt/partition.scm \ %D%/installer/newt/services.scm \ + %D%/installer/newt/substitutes.scm \ %D%/installer/newt/timezone.scm \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 7701297411..a6b9e3d952 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -34,6 +34,7 @@ #:use-module ((guix store) #:select (%store-prefix)) #:use-module (gnu installer) #:use-module (gnu system locale) + #:use-module (gnu services avahi) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services shepherd) @@ -335,6 +336,10 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; The usual services. (syslog-service) + ;; Use the Avahi daemon to discover substitute servers on the local + ;; network. It can be faster than fetching from remote servers. + (service avahi-service-type) + ;; The build daemon. Register the default substitute server key(s) ;; as trusted to allow the installation process to use substitutes by ;; default. @@ -435,6 +440,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m (host-name "gnu") (timezone "Europe/Paris") (locale "en_US.utf8") + (name-service-switch %mdns-host-lookup-nss) (bootloader (bootloader-configuration (bootloader grub-bootloader) (target "/dev/sda"))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 5afb13ffdb..1aec3bef3c 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -25,6 +25,7 @@ gnu/installer/newt/network.scm gnu/installer/newt/page.scm gnu/installer/newt/partition.scm gnu/installer/newt/services.scm +gnu/installer/newt/substitutes.scm gnu/installer/newt/timezone.scm gnu/installer/newt/user.scm gnu/installer/newt/utils.scm -- 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 'gnu/system') 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