TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

pack: Move common build code to (guix build pack). 

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.

Reviewed-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Maxim Cournoyer 2023-03-03 21:09:33 -05:00
parent 772eaa69f3
commit d5f8b50365
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
3 changed files with 293 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
guix/build/pack.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -17,8 +17,25 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build pack) (define-module (guix build pack)
#:use-module (gnu build install)
#:use-module (guix build utils) #: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))
;;; 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* (tar-base-options #:key tar compressor) (define* (tar-base-options #:key tar compressor)
"Return the base GNU tar options required to produce deterministic archives "Return the base GNU tar options required to produce deterministic archives
@ -52,3 +69,93 @@ the `-I' option."
;; process. Use '--hard-dereference' to eliminate it. ;; process. Use '--hard-dereference' to eliminate it.
"--hard-dereference" "--hard-dereference"
"--check-links")) "--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 "
(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")
(when localstatedir?
(unless store-database
(error "missing STORE-DATABASE argument")))
(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")
localstatedir?
store-database
deduplicate?
symlinks
compressor-command)
"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."
(populate-profile-root profile
#:profile-name profile-name
#:localstatedir? localstatedir?
#:store-database store-database
#:deduplicate? deduplicate?
#:symlinks symlinks)
(assert-utf8-locale)
;; 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)))

355
guix/scripts/pack.scm
View File

@ -72,6 +72,14 @@
%formats %formats
guix-pack)) guix-pack))
;;; 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:
;; This one is only for use in this module, so don't put it in %compressors. ;; This one is only for use in this module, so don't put it in %compressors.
(define bootstrap-xz (define bootstrap-xz
(compressor "bootstrap-xz" ".xz" (compressor "bootstrap-xz" ".xz"
@ -197,153 +205,18 @@ target the profile's @file{bin/env} file:
"Configure the environment to use the \"en_US.utf8\" locale provided by the "Configure the environment to use the \"en_US.utf8\" locale provided by the
GLIBC-UT8-LOCALES package." GLIBC-UT8-LOCALES package."
;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
(and (or (not (profile? profile)) (if (or (not (profile? profile))
(profile-locales? 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?)
#~(begin #~(begin
(use-modules (guix build pack) (setenv "GUIX_LOCPATH"
(guix build store-copy) #+(file-append glibc-utf8-locales "/lib/locale"))
(guix build utils) (setlocale LC_ALL "en_US.utf8"))
((guix build union) #:select (relative-file-name)) #~(setenv "GUIX_LOCPATH" "unset for tests")))
(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)))
;;; ;;;
;;; Tarball format. ;;; 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 (define* (self-contained-tarball name profile
#:key target #:key target
(profile-name "guix-profile") (profile-name "guix-profile")
@ -365,16 +238,48 @@ added to the pack."
(warning (G_ "entry point not supported in the '~a' format~%") (warning (G_ "entry point not supported in the '~a' format~%")
'tarball)) 'tarball))
(gexp->derivation (string-append name ".tar" (define database
(compressor-extension compressor)) (and localstatedir?
(self-contained-tarball/builder profile (file-append (store-database (list profile))
#:profile-name profile-name "/db/db.sqlite")))
#:target target
#:localstatedir? localstatedir? (gexp->derivation
#:deduplicate? deduplicate? (string-append name ".tar" (compressor-extension compressor))
#:symlinks symlinks ;; XXX: The conditional around deduplicate? is to allow the test to run
#:compressor compressor ;; without an external store.
#:archiver archiver))) (with-extensions (if deduplicate? (list guile-gcrypt) '())
(with-imported-modules (let ((lst (source-module-closure
'((guix build pack)
(guix build utils))
#:select? not-config?)))
(if deduplicate?
lst
(delete '(guix store deduplication) lst)))
(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)
(setenv "PATH" #+(file-append archiver "/bin"))
(build-self-contained-tarball #$profile
#$output
#:profile-name #$profile-name
#:localstatedir? #$localstatedir?
#:store-database #+database
#:deduplicate? #$deduplicate?
#:symlinks '#$symlinks
#:compressor-command
#+(and=> compressor
compressor-command)))))
#:target target
#:references-graphs `(("profile" ,profile))))
;;; ;;;
@ -719,20 +624,10 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
(warning (G_ "entry point not supported in the '~a' format~%") (warning (G_ "entry point not supported in the '~a' format~%")
'deb)) 'deb))
(define data-tarball (define database
(computed-file (string-append "data.tar" (compressor-extension (and localstatedir?
compressor)) (file-append (store-database (list profile))
(self-contained-tarball/builder profile "/db/db.sqlite")))
#: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 build (define build
(with-extensions (list guile-gcrypt) (with-extensions (list guile-gcrypt)
@ -750,6 +645,9 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
(ice-9 optargs) (ice-9 optargs)
(srfi srfi-1)) (srfi srfi-1))
;; Make sure non-ASCII file names are properly handled.
#+(set-utf8-locale profile)
(define machine-type (define machine-type
;; Extract the machine type from the specified target, else from the ;; Extract the machine type from the specified target, else from the
;; current system. ;; current system.
@ -803,10 +701,26 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
(lambda (port) (lambda (port)
(format port "~a~%" debian-format-version))) (format port "~a~%" debian-format-version)))
(define data-tarball-file-name (strip-store-file-name (define compressor-command
#+data-tarball)) #+(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))
(setenv "PATH" #+(file-append archiver "/bin"))
(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)
;; Generate the control archive. ;; Generate the control archive.
(let-keywords '#$extra-options #f (let-keywords '#$extra-options #f
@ -815,8 +729,7 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
(triggers-file #f)) (triggers-file #f))
(define control-tarball-file-name (define control-tarball-file-name
(string-append "control.tar" (string-append "control.tar" compressor-extension))
#$(compressor-extension compressor)))
;; Write the compressed control tarball. Only the control file is ;; Write the compressed control tarball. Only the control file is
;; mandatory (see: 'man deb' and 'man deb-control'). ;; mandatory (see: 'man deb' and 'man deb-control').
@ -846,7 +759,7 @@ Section: misc
(apply invoke tar (apply invoke tar
`(,@(tar-base-options `(,@(tar-base-options
#:tar tar #:tar tar
#:compressor #+(and=> compressor compressor-command)) #:compressor compressor-command)
"-cvf" ,control-tarball-file-name "-cvf" ,control-tarball-file-name
"control" "control"
,@(if postinst-file '("postinst") '()) ,@(if postinst-file '("postinst") '())
@ -857,7 +770,9 @@ Section: misc
"debian-binary" "debian-binary"
control-tarball-file-name data-tarball-file-name)))))) 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))))
;;; ;;;
@ -881,66 +796,27 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
(when entry-point (when entry-point
(warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) (warning (G_ "entry point not supported in the '~a' format~%") 'rpm))
(define root (populate-profile-root profile (define database
#:profile-name profile-name (and localstatedir?
#:target target (file-append (store-database (list profile))
#:localstatedir? localstatedir? "/db/db.sqlite")))
#: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 build (define build
(with-extensions (list guile-gcrypt) (with-extensions (list guile-gcrypt)
(with-imported-modules `(((guix config) => ,(make-config.scm)) (with-imported-modules `(((guix config) => ,(make-config.scm))
,@(source-module-closure ,@(source-module-closure
`((gcrypt hash) `((gcrypt hash)
(guix build pack)
(guix build utils) (guix build utils)
(guix cpio)
(guix profiles) (guix profiles)
(guix rpm)) (guix rpm))
#:select? not-config?)) #:select? not-config?))
#~(begin #~(begin
(use-modules (gcrypt hash) (use-modules (gcrypt hash)
(guix build pack)
(guix build utils) (guix build utils)
(guix cpio)
(guix profiles) (guix profiles)
(guix rpm) (guix rpm)
(ice-9 binary-ports) (ice-9 binary-ports)
@ -952,6 +828,35 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
;; Make sure non-ASCII file names are properly handled. ;; Make sure non-ASCII file names are properly handled.
#+(set-utf8-locale profile) #+(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 (define machine-type
(and=> (or #$target %host-type) (and=> (or #$target %host-type)
(lambda (triplet) (lambda (triplet)
@ -979,7 +884,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
#:target (or #$target %host-type))) #:target (or #$target %host-type)))
(define payload-digest (define payload-digest
(bytevector->hex-string (file-sha256 #$payload))) (bytevector->hex-string (file-sha256 cpio-file-name)))
(let-keywords '#$extra-options #f ((relocatable? #f) (let-keywords '#$extra-options #f ((relocatable? #f)
(prein-file #f) (prein-file #f)
@ -989,7 +894,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
(let ((header (generate-header name version (let ((header (generate-header name version
payload-digest payload-digest
#$root %root
#$(compressor-name compressor) #$(compressor-name compressor)
#:target (or #$target %host-type) #:target (or #$target %host-type)
#:relocatable? relocatable? #:relocatable? relocatable?
@ -1001,7 +906,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
(define header-sha256 (define header-sha256
(bytevector->hex-string (sha256 (u8-list->bytevector header)))) (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 (define header+compressed-payload-size
(+ (length header) payload-size)) (+ (length header) payload-size))
@ -1011,7 +916,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
header+compressed-payload-size)) header+compressed-payload-size))
;; Serialize the archive components to a file. ;; Serialize the archive components to a file.
(call-with-input-file #$payload (call-with-input-file cpio-file-name
(lambda (in) (lambda (in)
(call-with-output-file #$output (call-with-output-file #$output
(lambda (out) (lambda (out)
@ -1020,7 +925,9 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
header)) header))
(sendfile out in payload-size))))))))))) (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))))
;;; ;;;

106
tests/pack.scm
View File

@ -76,65 +76,65 @@
(test-begin "pack") (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 ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, ;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus,
;; run it on the user's store, if it's available, on the grounds that these ;; 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 ;; dependencies may be already there, or we can get substitutes or build them
;; quite inexpensively; see <https://bugs.gnu.org/32184>. ;; quite inexpensively; see <https://bugs.gnu.org/32184>.
(with-external-store store (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)) (unless store (test-skip 1))
(test-assertm "self-contained-tarball + localstatedir" store (test-assertm "self-contained-tarball + localstatedir" store
(mlet* %store-monad (mlet* %store-monad