pack: Extract populate-profile-root from self-contained-tarball/builder.
This allows more code to be reused between the various archive writers. * guix/scripts/pack.scm (set-utf8-locale): New top-level procedure, extracted from... (populate-profile-root): New procedure, extracted from... (self-contained-tarball/builder): ... here. Add #:target argument. Call populate-profile-root. [LOCALSTATEDIR?]: Set db.sqlite file permissions. (self-contained-tarball): Call self-contained-tarball/builder with the TARGET argument, and set #:local-build? to #f for the gexp-derivation call. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. (debian-archive): Call self-contained-tarball/builder with the #:target argument. Fix indentation. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call.
This commit is contained in:
Maxim Cournoyer
parent
68775338a5
commit
68380db4c4
|
|
@ -194,104 +194,144 @@ target the profile's @file{bin/env} file:
|
|||
(leave (G_ "~a: invalid symlink specification~%")
|
||||
arg))))
|
||||
|
||||
(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 (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
|
||||
(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
|
||||
#:options (list #:references-graphs `(("profile" ,profile))
|
||||
#:target target)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Tarball format.
|
||||
;;;
|
||||
(define* (self-contained-tarball/builder profile
|
||||
#:key (profile-name "guix-profile")
|
||||
(compressor (first %compressors))
|
||||
target
|
||||
localstatedir?
|
||||
(symlinks '())
|
||||
(archiver tar)
|
||||
(extra-options '()))
|
||||
"Return the G-Expression of the builder used for self-contained-tarball."
|
||||
(define database
|
||||
(and localstatedir?
|
||||
(file-append (store-database (list profile))
|
||||
"/db/db.sqlite")))
|
||||
deduplicate?
|
||||
symlinks
|
||||
compressor
|
||||
archiver)
|
||||
"Return a GEXP that can build a self-contained tarball."
|
||||
|
||||
(define set-utf8-locale
|
||||
;; 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 root (populate-profile-root profile
|
||||
#:profile-name profile-name
|
||||
#:target target
|
||||
#:localstatedir? localstatedir?
|
||||
#:deduplicate? deduplicate?
|
||||
#:symlinks symlinks))
|
||||
|
||||
(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))))
|
||||
|
||||
(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?)
|
||||
(with-imported-modules (source-module-closure '((guix build pack)
|
||||
(guix build utils)))
|
||||
#~(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 %root "root")
|
||||
|
||||
(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))
|
||||
(guix build utils))
|
||||
|
||||
;; Make sure non-ASCII file names are properly handled.
|
||||
#+set-utf8-locale
|
||||
#+(set-utf8-locale profile)
|
||||
|
||||
(define tar #+(file-append archiver "/bin/tar"))
|
||||
|
||||
;; Note: there is not much to gain here with deduplication and there
|
||||
;; is the overhead of the '.links' directory, so turn it off.
|
||||
;; 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? #f)
|
||||
(define %root (if #$localstatedir? "." #$root))
|
||||
|
||||
(when #+localstatedir?
|
||||
(install-database-and-gc-roots %root #+database #$profile
|
||||
#:profile-name #$profile-name))
|
||||
(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))
|
||||
|
||||
;; Create SYMLINKS.
|
||||
(for-each (cut evaluate-populate-directive <> %root)
|
||||
directives)
|
||||
|
||||
;; Create the tarball.
|
||||
(with-directory-excursion %root
|
||||
;; GNU Tar recurses directories by default. Simply add the whole
|
||||
;; current directory, which contains all the generated files so far.
|
||||
;; 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 "."
|
||||
|
|
@ -320,17 +360,16 @@ added to the pack."
|
|||
(warning (G_ "entry point not supported in the '~a' format~%")
|
||||
'tarball))
|
||||
|
||||
(gexp->derivation
|
||||
(string-append name ".tar"
|
||||
(compressor-extension compressor))
|
||||
(self-contained-tarball/builder profile
|
||||
#:profile-name profile-name
|
||||
#:compressor compressor
|
||||
#:localstatedir? localstatedir?
|
||||
#:symlinks symlinks
|
||||
#:archiver archiver)
|
||||
#:target target
|
||||
#:references-graphs `(("profile" ,profile))))
|
||||
(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)))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -676,13 +715,15 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
|
|||
'deb))
|
||||
|
||||
(define data-tarball
|
||||
(computed-file (string-append "data.tar"
|
||||
(compressor-extension compressor))
|
||||
(computed-file (string-append "data.tar" (compressor-extension
|
||||
compressor))
|
||||
(self-contained-tarball/builder profile
|
||||
#:target target
|
||||
#:profile-name profile-name
|
||||
#:compressor compressor
|
||||
#:localstatedir? localstatedir?
|
||||
#:deduplicate? deduplicate?
|
||||
#:symlinks symlinks
|
||||
#:compressor compressor
|
||||
#:archiver archiver)
|
||||
#:local-build? #f ;allow offloading
|
||||
#:options (list #:references-graphs `(("profile" ,profile))
|
||||
|
|
@ -811,10 +852,7 @@ Section: misc
|
|||
"debian-binary"
|
||||
control-tarball-file-name data-tarball-file-name))))))
|
||||
|
||||
(gexp->derivation (string-append name ".deb")
|
||||
build
|
||||
#:target target
|
||||
#:references-graphs `(("profile" ,profile))))
|
||||
(gexp->derivation (string-append name ".deb") build))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Reference in New Issue