[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#61949] [PATCH] pack: Move common build code to (guix build pack).
|
From: |
Maxim Cournoyer |
|
Subject: |
[bug#61949] [PATCH] pack: Move common build code to (guix build pack). |
|
Date: |
Fri, 3 Mar 2023 22:15:23 -0500 |
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(-)
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
(triggers-file #f))
(define control-tarball-file-name
- (string-append "control.tar"
- #$(compressor-extension compressor)))
+ (string-append "control.tar" compressor-extension))
;; Write the compressed control tarball. Only the control file
is
;; mandatory (see: 'man deb' and 'man deb-control').
@@ -848,7 +751,7 @@ (define tar (string-append #+archiver "/bin/tar"))
(apply invoke tar
`(,@(tar-base-options
#:tar tar
- #:compressor #+(and=> compressor compressor-command))
+ #:compressor compressor-command)
"-cvf" ,control-tarball-file-name
"control"
,@(if postinst-file '("postinst") '())
@@ -859,7 +762,9 @@ (define tar (string-append #+archiver "/bin/tar"))
"debian-binary"
control-tarball-file-name data-tarball-file-name))))))
- (gexp->derivation (string-append name ".deb") build))
+ (gexp->derivation (string-append name ".deb") build
+ #:target target
+ #:references-graphs `(("profile" ,profile))))
;;;
@@ -883,66 +788,27 @@ (define* (rpm-archive name profile
(when entry-point
(warning (G_ "entry point not supported in the '~a' format~%") 'rpm))
- (define root (populate-profile-root profile
- #:profile-name profile-name
- #:target target
- #:localstatedir? localstatedir?
- #:deduplicate? deduplicate?
- #:symlinks symlinks))
-
- (define payload
- (let* ((raw-cpio-file-name "payload.cpio")
- (compressed-cpio-file-name (string-append raw-cpio-file-name
- (compressor-extension
- compressor))))
- (computed-file compressed-cpio-file-name
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (guix cpio)
- (guix rpm)))
- #~(begin
- (use-modules (guix build utils)
- (guix cpio)
- (guix rpm)
- (srfi srfi-1))
-
- ;; Make sure non-ASCII file names are properly handled.
- #+(set-utf8-locale profile)
-
- (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))
-
- (call-with-output-file #$raw-cpio-file-name
- (lambda (port)
- (with-directory-excursion %root
- ;; The first "." entry is discarded.
- (write-cpio-archive
- (remove fhs-directory?
- (cdr (find-files "." #:directories? #t)))
- port))))
- (when #+(compressor-command compressor)
- (apply invoke (append #+(compressor-command compressor)
- (list #$raw-cpio-file-name))))
- (copy-file #$compressed-cpio-file-name #$output)))
- #:local-build? #f))) ;allow offloading
+ (define database
+ (and localstatedir?
+ (file-append (store-database (list profile))
+ "/db/db.sqlite")))
(define build
(with-extensions (list guile-gcrypt)
(with-imported-modules `(((guix config) => ,(make-config.scm))
,@(source-module-closure
`((gcrypt hash)
+ (guix build pack)
(guix build utils)
+ (guix cpio)
(guix profiles)
(guix rpm))
#:select? not-config?))
#~(begin
(use-modules (gcrypt hash)
+ (guix build pack)
(guix build utils)
+ (guix cpio)
(guix profiles)
(guix rpm)
(ice-9 binary-ports)
@@ -954,6 +820,35 @@ (define build
;; Make sure non-ASCII file names are properly handled.
#+(set-utf8-locale profile)
+ (define %root "root")
+
+ (populate-profile-root! #$profile
+ #:profile-name #$profile-name
+ #:localstatedir? #$localstatedir?
+ #:store-database #+database
+ #:deduplicate? #$deduplicate?
+ #:symlinks '#$symlinks)
+
+ (define raw-cpio-file-name "payload.cpio")
+
+ ;; Generate CPIO payload.
+ (call-with-output-file raw-cpio-file-name
+ (lambda (port)
+ (with-directory-excursion %root
+ ;; The first "." entry is discarded.
+ (write-cpio-archive
+ (remove fhs-directory?
+ (cdr (find-files "." #:directories? #t)))
+ port))))
+
+ (when #+(compressor-command compressor)
+ (apply invoke (append #+(compressor-command compressor)
+ (list raw-cpio-file-name))))
+
+ (define cpio-file-name
+ (string-append "payload.cpio"
+ #$(compressor-extension compressor)))
+
(define machine-type
(and=> (or #$target %host-type)
(lambda (triplet)
@@ -981,7 +876,7 @@ (define lead
#:target (or #$target %host-type)))
(define payload-digest
- (bytevector->hex-string (file-sha256 #$payload)))
+ (bytevector->hex-string (file-sha256 cpio-file-name)))
(let-keywords '#$extra-options #f ((relocatable? #f)
(prein-file #f)
@@ -991,7 +886,7 @@ (define payload-digest
(let ((header (generate-header name version
payload-digest
- #$root
+ %root
#$(compressor-name compressor)
#:target (or #$target %host-type)
#:relocatable? relocatable?
@@ -1003,7 +898,7 @@ (define payload-digest
(define header-sha256
(bytevector->hex-string (sha256 (u8-list->bytevector
header))))
- (define payload-size (stat:size (stat #$payload)))
+ (define payload-size (stat:size (stat cpio-file-name)))
(define header+compressed-payload-size
(+ (length header) payload-size))
@@ -1013,7 +908,7 @@ (define signature
header+compressed-payload-size))
;; Serialize the archive components to a file.
- (call-with-input-file #$payload
+ (call-with-input-file cpio-file-name
(lambda (in)
(call-with-output-file #$output
(lambda (out)
@@ -1022,7 +917,9 @@ (define signature
header))
(sendfile out in payload-size)))))))))))
- (gexp->derivation (string-append name ".rpm") build))
+ (gexp->derivation (string-append name ".rpm") build
+ #:target target
+ #:references-graphs `(("profile" ,profile))))
;;;
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..397fb37b12 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -76,64 +76,64 @@ (define rpm-for-tests
(test-begin "pack")
-(unless (network-reachable?) (test-skip 1))
-(test-assertm "self-contained-tarball" %store
- (mlet* %store-monad
- ((profile -> (profile
- (content (packages->manifest (list %bootstrap-guile)))
- (hooks '())
- (locales? #f)))
- (tarball (self-contained-tarball "pack" profile
- #:symlinks '(("/bin/Guile"
- -> "bin/guile"))
- #:compressor %gzip-compressor
- #:archiver %tar-bootstrap))
- (check (gexp->derivation "check-tarball"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1))
-
- (define store
- ;; The unpacked store.
- (string-append "." (%store-directory) "/"))
-
- (define (canonical? file)
- ;; Return #t if FILE is read-only and its mtime is 1.
- (let ((st (lstat file)))
- (or (not (string-prefix? store file))
- (eq? 'symlink (stat:type st))
- (and (= 1 (stat:mtime st))
- (zero? (logand #o222
- (stat:mode st)))))))
-
- (define bin
- (string-append "." #$profile "/bin"))
-
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
- (mkdir #$output)
- (exit
- (and (file-exists? (string-append bin "/guile"))
- (file-exists? store)
- (every canonical?
- (find-files "." (const #t)
- #:directories? #t))
- (string=? (string-append #$%bootstrap-guile
"/bin")
- (readlink bin))
- (string=? (string-append ".." #$profile
- "/bin/guile")
- (readlink "bin/Guile")))))))))
- (built-derivations (list check))))
-
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus,
;; run it on the user's store, if it's available, on the grounds that these
;; dependencies may be already there, or we can get substitutes or build them
;; quite inexpensively; see <https://bugs.gnu.org/32184>.
-
(with-external-store store
+ (unless store (test-skip 1))
+ (test-assertm "self-contained-tarball" store
+ (mlet* %store-monad
+ ((guile (set-guile-for-build (default-guile)))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
+ (tarball (self-contained-tarball "pack" profile
+ #:symlinks '(("/bin/Guile"
+ -> "bin/guile"))
+ #:compressor %gzip-compressor
+ #:archiver %tar-bootstrap))
+ (check (gexp->derivation "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (srfi srfi-1))
+
+ (define store
+ ;; The unpacked store.
+ (string-append "." (%store-directory) "/"))
+
+ (define (canonical? file)
+ ;; Return #t if FILE is read-only and its mtime is
1.
+ (let ((st (lstat file)))
+ (or (not (string-prefix? store file))
+ (eq? 'symlink (stat:type st))
+ (and (= 1 (stat:mtime st))
+ (zero? (logand #o222
+ (stat:mode st)))))))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+ (mkdir #$output)
+ (exit
+ (and (file-exists? (string-append bin "/guile"))
+ (file-exists? store)
+ (every canonical?
+ (find-files "." (const #t)
+ #:directories? #t))
+ (string=? (string-append #$%bootstrap-guile
"/bin")
+ (readlink bin))
+ (string=? (string-append ".." #$profile
+ "/bin/guile")
+ (readlink "bin/Guile")))))))))
+ (built-derivations (list check))))
+
(unless store (test-skip 1))
(test-assertm "self-contained-tarball + localstatedir" store
(mlet* %store-monad
base-commit: 89e5f3f3847b3bfd507ea9f0874a73f99a53cbf9
--
2.39.1
- [bug#61949] [PATCH] pack: Move common build code to (guix build pack).,
Maxim Cournoyer <=