From 1baaf599a4000451a54dcf30098a998f1b5bc70f Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Thu, 24 Jun 2021 21:36:48 +0200 Subject: vm: Update deprecated QEMU option syntax. Fixes: warning: short-form boolean option 'readonly' deprecated Please use readonly=on instead * gnu/system/vm.scm (common-qemu-options): Use it instead. --- gnu/system/vm.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f3bccec989..3390f5a88f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -713,7 +713,7 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." #$@(map virtfs-option shared-fs) "-vga std" - (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" + (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on" #$image))) (define* (system-qemu-image/shared-store-script os -- cgit v1.2.3 From 4f3bdc8f21657dbda857027b3ec8754dd4c7c67b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:22:35 -0400 Subject: pack: Prevent duplicate files in tar archives. Tar translate duplicate files in the archive into hard links. These can cause problems, as not every tool support them; for example dpkg doesn't. * gnu/system/file-systems.scm (reduce-directories): New procedure. (file-prefix?): Lift the restriction on file prefix. The procedure can be useful for comparing relative file names. Adjust doc. (file-name-depth): New procedure, extracted from ... (btrfs-store-subvolume-file-name): ... here. * guix/scripts/pack.scm (self-contained-tarball/builder): Use reduce-directories. * tests/file-systems.scm ("reduce-directories"): New test. --- gnu/system/file-systems.scm | 56 ++++++++++++++++++++++++++++++--------------- guix/scripts/pack.scm | 6 +++-- tests/file-systems.scm | 7 +++++- 3 files changed, 48 insertions(+), 21 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 464e87cb18..fb87bfc85b 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,6 +55,7 @@ file-system-dependencies file-system-location + reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -231,8 +232,8 @@ (char-set-complement (char-set #\/))) (define (file-prefix? file1 file2) - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2, -where both FILE1 and FILE2 are absolute file name. For example: + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2. +For example: (file-prefix? \"/gnu\" \"/gnu/store\") => #t @@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name. For example: (file-prefix? \"/gn\" \"/gnu/store\") => #f " - (and (string-prefix? "/" file1) - (string-prefix? "/" file2) - (let loop ((file1 (string-tokenize file1 %not-slash)) - (file2 (string-tokenize file2 %not-slash))) - (match file1 - (() - #t) - ((head1 tail1 ...) - (match file2 - ((head2 tail2 ...) - (and (string=? head1 head2) (loop tail1 tail2))) - (() - #f))))))) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f)))))) + +(define (file-name-depth file-name) + (length (string-tokenize file-name %not-slash))) + +(define (reduce-directories file-names) + "Eliminate entries in FILE-NAMES that are children of other entries in +FILE-NAMES. This is for example useful when passing a list of files to GNU +tar, which would otherwise descend into each directory passed and archive the +duplicate files as hard links, which can be undesirable." + (let* ((file-names/sorted + ;; Ascending sort by file hierarchy depth, then by file name length. + (stable-sort (delete-duplicates file-names) + (lambda (f1 f2) + (let ((depth1 (file-name-depth f1)) + (depth2 (file-name-depth f2))) + (if (= depth1 depth2) + (string< f1 f2) + (< depth1 depth2))))))) + (reverse (fold (lambda (file-name results) + (if (find (cut file-prefix? <> file-name) results) + results ;parent found -- skipping + (cons file-name results))) + '() + file-names/sorted)))) (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a @@ -624,9 +647,6 @@ store is located, else #f." s (string-append "/" s))) - (define (file-name-depth file-name) - (length (string-tokenize file-name %not-slash))) - (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems)) (btrfs-subvolume-fs* (sort btrfs-subvolume-fs diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 952c1455be..cee1444110 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -230,13 +230,15 @@ its source property." `((guix build pack) (guix build utils) (guix build union) - (gnu build install)) + (gnu build install) + (gnu system file-systems)) #:select? import-module?) #~(begin (use-modules (guix build pack) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) + ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -303,7 +305,7 @@ its source property." ,(string-append "." (%store-directory)) - ,@(delete-duplicates + ,@(reduce-directories (filter-map (match-lambda (('directory directory) (string-append "." directory)) diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 7f7c373884..80acb6d5b9 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,6 +50,11 @@ (device "/foo") (flags '(bind-mount read-only))))))))) +(test-equal "reduce-directories" + '("./opt/gnu/" "./opt/gnuism" "a/b/c") + (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" + "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) + (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit v1.2.3 From 7cde70c7f88e1b283bb61d8a35c5ceeafb39884e Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 30 Jun 2021 14:20:01 -0400 Subject: file-systems: Ensure compared file names are both absolute or relative. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system/file-systems.scm (file-prefix?): Return #f unless both file names are absolute or relative. Reported-by: Ludovic Courtès --- gnu/system/file-systems.scm | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index fb87bfc85b..4a3c1fe008 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Google LLC ;;; Copyright © 2020 Jakub Kądziołka -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -233,6 +233,9 @@ (define (file-prefix? file1 file2) "Return #t if FILE1 denotes the name of a file that is a parent of FILE2. +FILE1 and FILE2 must both be either absolute or relative file names, else #f +is returned. + For example: (file-prefix? \"/gnu\" \"/gnu/store\") @@ -241,17 +244,24 @@ For example: (file-prefix? \"/gn\" \"/gnu/store\") => #f " - (let loop ((file1 (string-tokenize file1 %not-slash)) - (file2 (string-tokenize file2 %not-slash))) - (match file1 - (() - #t) - ((head1 tail1 ...) - (match file2 - ((head2 tail2 ...) - (and (string=? head1 head2) (loop tail1 tail2))) - (() - #f)))))) + (define (absolute? file) + (string-prefix? "/" file)) + + (if (or (every absolute? (list file1 file2)) + (every (negate absolute?) (list file1 file2))) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f))))) + ;; FILE1 and FILE2 are a mix of absolute and relative file names. + #f)) (define (file-name-depth file-name) (length (string-tokenize file-name %not-slash))) -- cgit v1.2.3 From 49e2e75ced01a821c84eb776cf42a36664eaa834 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 8 Jul 2021 09:39:05 +0300 Subject: gnu: %guile-3.0-static-stripped: Rename to %guile-static-stripped. * gnu/packages/make-bootstrap.scm (%guile-3.0-static-stripped): Rename to %guile-static-stripped. (%guile-bootstrap-tarball): Adjust accordingly. * gnu/system/linux-initrd.scm (expression->initrd): Use %guile-static-stripped as default guile. * doc/guix.texi (initial RAM disk)[expression->initrd]: Adjust documentation accordingly. --- doc/guix.texi | 2 +- gnu/packages/make-bootstrap.scm | 6 +++--- gnu/system/linux-initrd.scm | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index e11f7adebb..18bc600440 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -32775,7 +32775,7 @@ program. That gives a lot of flexibility. The program to run in that initrd. @deffn {Scheme Procedure} expression->initrd @var{exp} @ - [#:guile %guile-3.0-static-stripped] [#:name "guile-initrd"] + [#:guile %guile-static-stripped] [#:name "guile-initrd"] Return as a file-like object a Linux initrd (a gzipped cpio archive) containing @var{guile} and that evaluates @var{exp}, a G-expression, upon booting. All the derivations referenced by @var{exp} are diff --git a/gnu/packages/make-bootstrap.scm b/gnu/packages/make-bootstrap.scm index d66acc2e70..cdcb1dcaa2 100644 --- a/gnu/packages/make-bootstrap.scm +++ b/gnu/packages/make-bootstrap.scm @@ -55,7 +55,7 @@ %mes-bootstrap-tarball %bootstrap-tarballs - %guile-3.0-static-stripped)) + %guile-static-stripped)) ;;; Commentary: ;;; @@ -798,7 +798,7 @@ for `sh' in $PATH, and without nscd, and with static NSS modules." (outputs '("out")) (synopsis "Minimal statically-linked and relocatable Guile"))) -(define %guile-3.0-static-stripped +(define %guile-static-stripped ;; A stripped static Guile 3.0 binary, for use in initrds ;; and during bootstrap. (make-guile-static-stripped @@ -863,7 +863,7 @@ for `sh' in $PATH, and without nscd, and with static NSS modules." (define %guile-bootstrap-tarball ;; A tarball with the statically-linked, relocatable Guile. - (tarball-package %guile-3.0-static-stripped)) + (tarball-package %guile-static-stripped)) (define %mescc-tools-bootstrap-tarball ;; A tarball with statically-linked MesCC binary seed. diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index c6ba9bb560..8c245b8445 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -36,7 +36,7 @@ #:use-module ((gnu packages xorg) #:select (console-setup xkeyboard-config)) #:use-module ((gnu packages make-bootstrap) - #:select (%guile-3.0-static-stripped)) + #:select (%guile-static-stripped)) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) #:use-module (gnu system keyboard) @@ -62,7 +62,7 @@ (define* (expression->initrd exp #:key - (guile %guile-3.0-static-stripped) + (guile %guile-static-stripped) (gzip gzip) (name "guile-initrd") (system (%current-system))) -- cgit v1.2.3 From 11f0698243da27be93b16cec574fbf262279779a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 6 Jul 2021 12:27:36 -0400 Subject: pack: Streamline how files are included in tarballs. Thanks to Guillem Jover on the OFTC's #debian-dpkg channel for helping with troubleshooting. Letting GNU Tar recursively walk the complete files hierarchy side-steps the risks associated with providing a list of file names: 1. Duplicated files in the archive (recorded as hard links by GNU Tar) 2. Missing parent directories. The above would cause dpkg to malfunction, for example by aborting early and skipping triggers when there were missing parent directories. * guix/scripts/pack.scm (self-contained-tarball/builder): Do not call POPULATE-SINGLE-PROFILE-DIRECTORY, which creates extraneous files such as /root. Instead, call POPULATE-STORE and INSTALL-DATABASE-AND-GC-ROOTS individually to more precisely generate the file system. Replace the list of files by the current directory, "." and streamline the way options are passed. * gnu/system/file-systems.scm (reduce-directories): Remove procedure. * tests/file-systems.scm ("reduce-directories"): Remove test. --- gnu/system/file-systems.scm | 22 -------------------- guix/scripts/pack.scm | 49 +++++++++++++++------------------------------ tests/file-systems.scm | 7 +------ 3 files changed, 17 insertions(+), 61 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4a3c1fe008..b9eda80958 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,7 +55,6 @@ file-system-dependencies file-system-location - reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -266,27 +265,6 @@ For example: (define (file-name-depth file-name) (length (string-tokenize file-name %not-slash))) -(define (reduce-directories file-names) - "Eliminate entries in FILE-NAMES that are children of other entries in -FILE-NAMES. This is for example useful when passing a list of files to GNU -tar, which would otherwise descend into each directory passed and archive the -duplicate files as hard links, which can be undesirable." - (let* ((file-names/sorted - ;; Ascending sort by file hierarchy depth, then by file name length. - (stable-sort (delete-duplicates file-names) - (lambda (f1 f2) - (let ((depth1 (file-name-depth f1)) - (depth2 (file-name-depth f2))) - (if (= depth1 depth2) - (string< f1 f2) - (< depth1 depth2))))))) - (reverse (fold (lambda (file-name results) - (if (find (cut file-prefix? <> file-name) results) - results ;parent found -- skipping - (cons file-name results))) - '() - file-names/sorted)))) - (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a record. When the device is a UUID, its representation is chosen depending on diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78201d6f5f..9e1f270dfb 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -231,17 +231,17 @@ its source property." (with-imported-modules (source-module-closure `((guix build pack) + (guix build store-copy) (guix build utils) (guix build union) - (gnu build install) - (gnu system file-systems)) + (gnu build install)) #:select? import-module?) #~(begin (use-modules (guix build pack) + (guix build store-copy) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) - ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -279,11 +279,11 @@ its source property." ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; with hard links: ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:profile-name #$profile-name - #:closure "profile" - #:database #+database) + (populate-store (list "profile") %root #:deduplicate? #f) + + (when #+localstatedir? + (install-database-and-gc-roots %root #+database #$profile + #:profile-name #$profile-name)) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -291,31 +291,14 @@ its source property." ;; Create the tarball. (with-directory-excursion %root - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor '#+(and=> compressor compressor-command)) - "-cvf" ,#$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - ,#$@(if localstatedir? - '("./var/guix") - '()) - - ,(string-append "." (%store-directory)) - - ,@(reduce-directories - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))) + ;; GNU Tar recurses directories by default. Simply add the whole + ;; current directory, which contains all the generated files so far. + ;; This avoids creating duplicate files in the archives that would + ;; be stored as hard links by GNU Tar. + (apply invoke tar "-cvf" #$output "." + (tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 80acb6d5b9..7f7c373884 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,11 +50,6 @@ (device "/foo") (flags '(bind-mount read-only))))))))) -(test-equal "reduce-directories" - '("./opt/gnu/" "./opt/gnuism" "a/b/c") - (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" - "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) - (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit v1.2.3