(address . guix-patches@gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20230304031523.24102-1-maxim.cournoyer@gmail.com
The rationale is to reduce the number of derivations built per pack to ideally
one, to minimize storage requirements. The number of derivations had gone up
with 68380db4 ("pack: Extract populate-profile-root from
self-contained-tarball/builder.") as a side effect to improving code reuse.
* guix/scripts/pack.scm (guix): Add commentary comment.
(populate-profile-root, self-contained-tarball/builder): Extract to...
* guix/build/pack.scm (populate-profile-root!): ... this, and...
(build-self-contained-tarball): ... that, adjusting for use on the build side.
(assert-utf8-locale): New procedure.
(self-contained-tarball, debian-archive, rpm-archive): Adjust accordingly.
---
guix/build/pack.scm | 115 +++++++++++++-
guix/scripts/pack.scm | 341 +++++++++++++++---------------------------
tests/pack.scm | 104 ++++++-------
3 files changed, 284 insertions(+), 276 deletions(-)
Toggle diff (430 lines)
diff --git a/guix/build/pack.scm b/guix/build/pack.scm
index 3b73d1b227..fa9a5f5905 100644
--- a/guix/build/pack.scm
+++ b/guix/build/pack.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -16,9 +16,26 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+;;; Commentary:
+
+;;; This module contains build-side common procedures used by the host-side
+;;; (guix scripts pack) module, mostly to allow for code reuse. Due to making
+;;; use of the (guix build store-copy) module, it transitively requires the
+;;; sqlite and gcrypt extensions to be available.
+
+;;; Code:
+
(define-module (guix build pack)
+ #:use-module (gnu build install)
#:use-module (guix build utils)
- #:export (tar-base-options))
+ #:use-module (guix build store-copy)
+ #:use-module ((guix build union) #:select (relative-file-name))
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (tar-base-options
+ populate-profile-root!
+ build-self-contained-tarball))
(define* (tar-base-options #:key tar compressor)
"Return the base GNU tar options required to produce deterministic archives
@@ -52,3 +69,97 @@ (define (tar-supports-sort? tar)
;; process. Use '--hard-dereference' to eliminate it.
"--hard-dereference"
"--check-links"))
+
+(define (assert-utf8-locale)
+ "Verify the current process is using the en_US.utf8 locale."
+ (unless (string=? "unset for tests" (getenv "GUIX_LOCPATH"))
+ (unless (false-if-exception (setlocale LC_ALL "en_US.utf8"))
+ (error "environment not configured for en_US.utf8 locale"))))
+
+(define* (populate-profile-root! profile
+ #:key (profile-name "guix-profile")
+ localstatedir?
+ store-database
+ deduplicate?
+ (symlinks '()))
+ "Populate the root profile directory with SYMLINKS and a Guix database, when
+LOCALSTATEDIR? is set, and a pre-computed STORE-DATABASE is provided. The
+directory is created as \"root\" in the current working directory. When
+DEDUPLICATE? is true, deduplicate the store items, which relies on hard
+links. It needs to run in an environment where "
+ (when localstatedir?
+ (unless store-database
+ (error "missing STORE-DATABASE argument")))
+
+ (define symlink->directives
+ ;; Return "populate directives" to make the given symlink and its
+ ;; parent directories.
+ (match-lambda
+ ((source '-> target)
+ (let ((target (string-append profile "/" target))
+ (parent (dirname source)))
+ ;; Never add a 'directory' directive for "/" so as to
+ ;; preserve its ownership when extracting the archive (see
+ ;; below), and also because this would lead to adding the
+ ;; same entries twice in the tarball.
+ `(,@(if (string=? parent "/")
+ '()
+ `((directory ,parent)))
+ ;; Use a relative file name for compatibility with
+ ;; relocatable packs.
+ (,source -> ,(relative-file-name parent target)))))))
+
+ (define directives
+ ;; Fully-qualified symlinks.
+ (append-map symlink->directives symlinks))
+
+ (define %root "root")
+
+ (assert-utf8-locale)
+
+ ;; Note: there is not much to gain here with deduplication and there
+ ;; is the overhead of the '.links' directory, so turn it off by
+ ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract
+ ;; tarballs with hard links:
+ ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+ (populate-store (list "profile") %root #:deduplicate? deduplicate?)
+
+ (when localstatedir?
+ (install-database-and-gc-roots %root store-database
+ profile #:profile-name profile-name))
+
+ ;; Create SYMLINKS.
+ (for-each (cut evaluate-populate-directive <> %root) directives))
+
+(define* (build-self-contained-tarball profile
+ tarball-file-name
+ #:key (profile-name "guix-profile")
+ target
+ localstatedir?
+ store-database
+ deduplicate?
+ symlinks
+ compressor-command
+ archiver)
+ "Create a self-contained tarball TARBALL-FILE-NAME from PROFILE, optionally
+compressing it with COMPRESSOR-COMMAND, the complete command-line string to
+use for the compressor."
+ (assert-utf8-locale)
+
+ (populate-profile-root! profile
+ #:profile-name profile-name
+ #:localstatedir? localstatedir?
+ #:store-database store-database
+ #:deduplicate? deduplicate?
+ #:symlinks symlinks)
+
+ (define tar (string-append archiver "/bin/tar"))
+
+ ;; GNU Tar recurses directories by default. Simply add the whole root
+ ;; directory, which contains all the files to be archived. This avoids
+ ;; creating duplicate files in the archives that would be stored as hard
+ ;; links by GNU Tar.
+ (apply invoke tar "-cvf" tarball-file-name "-C" "root" "."
+ (tar-base-options
+ #:tar tar
+ #:compressor compressor-command)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index eb41eb5563..984622bd16 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -24,6 +24,14 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+;;; Commentary:
+
+;;; This module implements the 'guix pack' command and the various supported
+;;; formats. Where feasible, the builders of the packs should be implemented
+;;; as single derivations to minimize storage requirements.
+
+;;; Code:
+
(define-module (guix scripts pack)
#:use-module (guix scripts)
#:use-module (guix ui)
@@ -199,153 +207,18 @@ (define (set-utf8-locale profile)
"Configure the environment to use the \"en_US.utf8\" locale provided by the
GLIBC-UT8-LOCALES package."
;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
- (and (or (not (profile? profile))
- (profile-locales? profile))
- #~(begin
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8"))))
-
-(define* (populate-profile-root profile
- #:key (profile-name "guix-profile")
- target
- localstatedir?
- deduplicate?
- (symlinks '()))
- "Populate the root profile directory with SYMLINKS and a Guix database, when
-LOCALSTATEDIR? is set. When DEDUPLICATE? is true, deduplicate the store
-items, which relies on hard links."
- (define database
- (and localstatedir?
- (file-append (store-database (list profile))
- "/db/db.sqlite")))
-
- (define bootstrap?
- ;; Whether a '--bootstrap' environment is needed, for testing purposes.
- ;; XXX: Infer that from available info.
- (and (not database) (not (profile-locales? profile))))
-
- (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, unless DEDUPLICATE? is #t. This makes it possible to run
- ;; tests with '--bootstrap'.
- (and (not-config? module)
- (or deduplicate? (not (equal? '(guix store deduplication) module)))))
-
- (computed-file "profile-directory"
- (with-imported-modules (source-module-closure
- `((guix build pack)
- (guix build store-copy)
- (guix build utils)
- (guix build union)
- (gnu build install))
- #:select? import-module?)
+ (if (or (not (profile? profile))
+ (profile-locales? profile))
#~(begin
- (use-modules (guix build pack)
- (guix build store-copy)
- (guix build utils)
- ((guix build union) #:select (relative-file-name))
- (gnu build install)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match))
-
- (define symlink->directives
- ;; Return "populate directives" to make the given symlink and its
- ;; parent directories.
- (match-lambda
- ((source '-> target)
- (let ((target (string-append #$profile "/" target))
- (parent (dirname source)))
- ;; Never add a 'directory' directive for "/" so as to
- ;; preserve its ownership when extracting the archive (see
- ;; below), and also because this would lead to adding the
- ;; same entries twice in the tarball.
- `(,@(if (string=? parent "/")
- '()
- `((directory ,parent)))
- ;; Use a relative file name for compatibility with
- ;; relocatable packs.
- (,source -> ,(relative-file-name parent target)))))))
-
- (define directives
- ;; Fully-qualified symlinks.
- (append-map symlink->directives '#$symlinks))
-
- ;; Make sure non-ASCII file names are properly handled.
- #+(set-utf8-locale profile)
-
- ;; Note: there is not much to gain here with deduplication and there
- ;; is the overhead of the '.links' directory, so turn it off by
- ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract
- ;; tarballs with hard links:
- ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
- (populate-store (list "profile") #$output
- #:deduplicate? #$deduplicate?)
-
- (when #+localstatedir?
- (install-database-and-gc-roots #$output #+database #$profile
- #:profile-name #$profile-name))
-
- ;; Create SYMLINKS.
- (for-each (cut evaluate-populate-directive <> #$output)
- directives)))
- #:local-build? #f
- #:guile (if bootstrap? %bootstrap-guile (default-guile))
- #:options (list #:references-graphs `(("profile" ,profile))
- #:target target)))
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8"))
+ #~(setenv "GUIX_LOCPATH" "unset for tests")))
;;;
;;; Tarball format.
;;;
-(define* (self-contained-tarball/builder profile
- #:key (profile-name "guix-profile")
- target
- localstatedir?
- deduplicate?
- symlinks
- compressor
- archiver)
- "Return a GEXP that can build a self-contained tarball."
-
- (define root (populate-profile-root profile
- #:profile-name profile-name
- #:target target
- #:localstatedir? localstatedir?
- #:deduplicate? deduplicate?
- #:symlinks symlinks))
-
- (with-imported-modules (source-module-closure '((guix build pack)
- (guix build utils)))
- #~(begin
- (use-modules (guix build pack)
- (guix build utils))
-
- ;; Make sure non-ASCII file names are properly handled.
- #+(set-utf8-locale profile)
-
- (define tar #+(file-append archiver "/bin/tar"))
-
- (define %root (if #$localstatedir? "." #$root))
-
- (when #$localstatedir?
- ;; Fix the permission of the Guix database file, which was made
- ;; read-only when copied to the store in populate-profile-root.
- (copy-recursively #$root %root)
- (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
-
- (with-directory-excursion %root
- ;; GNU Tar recurses directories by default. Simply add the whole
- ;; current directory, which contains all the files to be archived.
- ;; 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
(profile-name "guix-profile")
@@ -367,16 +240,39 @@ (define* (self-contained-tarball name profile
(warning (G_ "entry point not supported in the '~a' format~%")
'tarball))
+ (define database
+ (and localstatedir?
+ (file-append (store-database (list profile))
+ "/db/db.sqlite")))
+
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
- (self-contained-tarball/builder profile
- #:profile-name profile-name
- #:target target
- #:localstatedir? localstatedir?
- #:deduplicate? deduplicate?
- #:symlinks symlinks
- #:compressor compressor
- #:archiver archiver)))
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ `((guix build pack)
+ (guix build utils))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (guix build pack)
+ (guix build utils))
+
+ ;; Make sure non-ASCII file names are properly handled.
+ #+(set-utf8-locale profile)
+
+ (build-self-contained-tarball #$profile
+ #$output
+ #:profile-name #$profile-name
+ #:target #$target
+ #:localstatedir? #$localstatedir?
+ #:store-database #+database
+ #:deduplicate? #$deduplicate?
+ #:symlinks '#$symlinks
+ #:compressor-command
+ #+(and=> compressor compressor-command)
+ #:archiver #+archiver))))
+ #:target target
+ #:references-graphs `(("profile" ,profile))))
;;;
@@ -721,20 +617,10 @@ (define %valid-compressors '("gzip" "xz" "none"))
(warning (G_ "entry point not supported in the '~a' format~%")
'deb))
- (define data-tarball
- (computed-file (string-append "data.tar" (compressor-extension
- compressor))
- (self-contained-tarball/builder profile
- #:target target
- #:profile-name profile-name
- #:localstatedir? localstatedir?
- #:deduplicate? deduplicate?
- #:symlinks symlinks
- #:compressor compressor
- #:archiver archiver)
- #:local-build? #f ;allow offloading
- #:options (list #:references-graphs `(("profile" ,profile))
- #:target target)))
+ (define database
+ (and localstatedir?
+ (file-append (store-database (list profile))
+ "/db/db.sqlite")))
(define build
(with-extensions (list guile-gcrypt)
@@ -752,6 +638,9 @@ (define build
(ice-9 optargs)
(srfi srfi-1))
+ ;; Make sure non-ASCII file names are properly handled.
+ #+(set-utf8-locale profile)
+
(define machine-type
;; Extract the machine type from the specified target, else from the
;; current system.
@@ -805,10 +694,25 @@ (define debian-format-version "2.0")
(lambda (port)
(format port "~a~%" debian-format-version)))
- (define data-tarball-file-name (strip-store-file-name
- #+data-tarball))
+ (define compressor-command
+ #+(and=> compressor compressor-command))
- (copy-file #+data-tarball data-tarball-file-name)
+ (define compressor-extension
+ #+(compressor-extension compressor))
+
+ (define data-tarball-file-name
+ (string-append "data.tar" compressor-extension))
+
+ (build-self-contained-tarball #$profile
+ data-tarball-file-name
+ #:profile-name #$profile-name
+ #:localstatedir? #$localstatedir?
+ #:store-database #+database
+ #:deduplicate? #$deduplicate?
+ #:symlinks '#$symlinks
+ #:compressor-command
+ compressor-command
+ #:archiver #+archiver)
;; Generate the control archive.
(let-keywords '#$extra-options #f
@@ -817,8 +721,7 @@ (define data-tarball-file-name (strip-store-file-name
This message was truncated. Download the full message here.