nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

install: Use (guix store database) instead of 'guix-register'. 

* gnu/build/install.scm (register-closure): Add #:reset-timestamps? and
and #:schema; honor them.  Rewrite in terms of 'register-path'.
(populate-single-profile-directory): Add #:schema and honor it.  Make
/var/guix/profiles and /var/guix/gcroots.
* gnu/build/vm.scm (root-partition-initializer): Pass
 #:reset-timestamps? to 'register-closure'.
* gnu/system/vm.scm (not-config?): New procedure.
(guile-sqlite3&co): New variable.
(expression->derivation-in-linux-vm)[config]: New variable.
[builder]: Use 'with-extensions'.
(iso9660-image)[schema, config]: New variables.
Wrap build expression in 'with-extensions'; add 'sql-schema' call.
Remove GUIX from INPUTS.
(qemu-image)[schema, config]: New variables.
Wrap body in 'with-extensions'.
(system-docker-image)[not-config?]: Remove.
[config]: Use 'make-config.scm'.
[schema]: New variable.
[build]: Use 'with-extensions'.  Add call to 'sql-schema'.  Remove GUIX
from INPUTS.
* gnu/system/file-systems.scm (%store-prefix): Check whether
'%store-prefix' is defined.
* guix/scripts/pack.scm (self-contained-tarball)[not-config?]
[libgcrypt, schema]: New variables.
[build]: Wrap in 'with-extensions'.  Adjust imported module list to use
'make-config.scm' for (guix config).
This commit is contained in:
Ludovic Courtès 2018-06-06 23:58:18 +02:00
parent be43c08b17
commit c45477d2a1
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 356 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gnu/build/install.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -18,6 +18,7 @@
;;; 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 (gnu build install) (define-module (gnu build install)
#:use-module (guix store database)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -158,23 +159,31 @@ as created and modified at the Epoch."
(utime file 0 0 0 0)))) (utime file 0 0 0 0))))
(find-files directory #:directories? #t))) (find-files directory #:directories? #t)))
(define* (register-closure store closure (define* (register-closure prefix closure
#:key (deduplicate? #t)) #:key
"Register CLOSURE in STORE, where STORE is the directory name of the target (deduplicate? #t) (reset-timestamps? #t)
store and CLOSURE is the name of a file containing a reference graph as used (schema (sql-schema)))
by 'guix-register'. As a side effect, this resets timestamps on store files "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the target store and CLOSURE is the name of a file containing a reference graph as
rest of STORE." produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
(let ((status (apply system* "guix-register" "--prefix" store true, reset timestamps on store files and, if DEDUPLICATE? is true,
(append (if deduplicate? '() '("--no-deduplication")) deduplicates files common to CLOSURE and the rest of PREFIX."
(list closure))))) (let ((items (call-with-input-file closure read-reference-graph)))
(unless (zero? status) ;; TODO: Add a procedure to register all of ITEMS at once.
(error "failed to register store items" closure)))) (for-each (lambda (item)
(register-path (store-info-item item)
#:references (store-info-references item)
#:deriver (store-info-deriver item)
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:schema schema))
items)))
(define* (populate-single-profile-directory directory (define* (populate-single-profile-directory directory
#:key profile closure #:key profile closure
deduplicate? deduplicate?
register?) register? schema)
"Populate DIRECTORY with a store containing PROFILE, whose closure is given "Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE. is initialized to contain a single profile under /root pointing to PROFILE.
@ -200,11 +209,11 @@ This is used to create the self-contained tarballs with 'guix pack'."
(when register? (when register?
(register-closure (canonicalize-path directory) closure (register-closure (canonicalize-path directory) closure
#:deduplicate? deduplicate?) #:deduplicate? deduplicate?
#:schema schema)
;; XXX: 'guix-register' registers profiles as GC roots but the symlink (mkdir-p* "/var/guix/profiles")
;; target uses $TMPDIR. Fix that. (mkdir-p* "/var/guix/gcroots")
(delete-file (scope "/var/guix/gcroots/profiles"))
(symlink* "/var/guix/profiles" (symlink* "/var/guix/profiles"
"/var/guix/gcroots/profiles")) "/var/guix/gcroots/profiles"))

1
gnu/build/vm.scm
View File

@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(for-each (lambda (closure) (for-each (lambda (closure)
(register-closure target (register-closure target
(string-append "/xchg/" closure) (string-append "/xchg/" closure)
#:reset-timestamps? copy-closures?
#:deduplicate? deduplicate?)) #:deduplicate? deduplicate?))
closures) closures)
(unless copy-closures? (unless copy-closures?

11
gnu/system/file-systems.scm
View File

@ -194,10 +194,15 @@
;; differs from user to user. ;; differs from user to user.
(define (%store-prefix) (define (%store-prefix)
"Return the store prefix." "Return the store prefix."
(cond ((resolve-module '(guix store) #:ensure #f) ;; Note: If we have (guix store database) in the search path and we do *not*
;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
;; with one sub-module.
(cond ((and=> (resolve-module '(guix store) #:ensure #f)
(lambda (store)
(module-variable store '%store-prefix)))
=> =>
(lambda (store) (lambda (variable)
((module-ref store '%store-prefix)))) ((variable-ref variable))))
((getenv "NIX_STORE") ((getenv "NIX_STORE")
=> identity) => identity)
(else (else

369
gnu/system/vm.scm
View File

@ -34,6 +34,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (guix hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module ((gnu build vm) #:use-module ((gnu build vm)
#:select (qemu-command)) #:select (qemu-command))
@ -50,7 +51,6 @@
#:use-module (gnu packages disk) #:use-module (gnu packages disk)
#:use-module (gnu packages zile) #:use-module (gnu packages zile)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap) #:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped)) #:select (%guile-static-stripped))
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
@ -116,6 +116,19 @@
(options "trans=virtio") (options "trans=virtio")
(check? #f)))) (check? #f))))
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define guile-sqlite3&co
;; Guile-SQLite3 and its propagated inputs.
(cons guile-sqlite3
(package-transitive-propagated-inputs guile-sqlite3)))
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
(system (%current-system)) (system (%current-system))
@ -151,6 +164,10 @@ based on the size of the closure of REFERENCES-GRAPHS.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share." made available under the /xchg CIFS share."
(define config
;; (guix config) module for consumption by (guix gcrypt).
(make-config.scm #:libgcrypt libgcrypt))
(define user-builder (define user-builder
(program-file "builder-in-linux-vm" exp)) (program-file "builder-in-linux-vm" exp))
@ -178,40 +195,44 @@ made available under the /xchg CIFS share."
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
(with-imported-modules (source-module-closure '((guix build utils) (with-extensions guile-sqlite3&co
(gnu build vm))) (with-imported-modules `(,@(source-module-closure
#~(begin '((guix build utils)
(use-modules (guix build utils) (gnu build vm))
(gnu build vm)) #:select? not-config?)
((guix config) => ,config))
#~(begin
(use-modules (guix build utils)
(gnu build vm))
(let* ((inputs '#$(list qemu coreutils)) (let* ((inputs '#$(list qemu (canonical-package coreutils)))
(linux (string-append #$linux "/" (linux (string-append #$linux "/"
#$(system-linux-image-file-name))) #$(system-linux-image-file-name)))
(initrd (string-append #$initrd "/initrd")) (initrd (string-append #$initrd "/initrd"))
(loader #$loader) (loader #$loader)
(graphs '#$(match references-graphs (graphs '#$(match references-graphs
(((graph-files . _) ...) graph-files) (((graph-files . _) ...) graph-files)
(_ #f))) (_ #f)))
(size #$(if (eq? 'guess disk-image-size) (size #$(if (eq? 'guess disk-image-size)
#~(+ (* 70 (expt 2 20)) ;ESP #~(+ (* 70 (expt 2 20)) ;ESP
(estimated-partition-size graphs)) (estimated-partition-size graphs))
disk-image-size))) disk-image-size)))
(set-path-environment-variable "PATH" '("bin") inputs) (set-path-environment-variable "PATH" '("bin") inputs)
(load-in-linux-vm loader (load-in-linux-vm loader
#:output #$output #:output #$output
#:linux linux #:initrd initrd #:linux linux #:initrd initrd
#:memory-size #$memory-size #:memory-size #$memory-size
#:make-disk-image? #$make-disk-image? #:make-disk-image? #$make-disk-image?
#:single-file-output? #$single-file-output? #:single-file-output? #$single-file-output?
;; FIXME: ‘target-arm32?’ may not operate on ;; FIXME: ‘target-arm32?’ may not operate on
;; the right system/target values. Rewrite ;; the right system/target values. Rewrite
;; using ‘let-system’ when available. ;; using ‘let-system’ when available.
#:target-arm32? #$(target-arm32?) #:target-arm32? #$(target-arm32?)
#:disk-image-format #$disk-image-format #:disk-image-format #$disk-image-format
#:disk-image-size size #:disk-image-size size
#:references-graphs graphs))))) #:references-graphs graphs))))))
(gexp->derivation name builder (gexp->derivation name builder
;; TODO: Require the "kvm" feature. ;; TODO: Require the "kvm" feature.
@ -234,42 +255,56 @@ made available under the /xchg CIFS share."
"Return a bootable, stand-alone iso9660 image. "Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)." INPUTS is a list of inputs (as for packages)."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema
(and register-closures?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-imported-modules (source-module-closure '((gnu build vm) (with-extensions guile-sqlite3&co
(guix build utils))) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
#~(begin (guix store database)
(use-modules (gnu build vm) (guix build utils))
(guix build utils)) #:select? not-config?)
((guix config) => ,config))
#~(begin
(use-modules (gnu build vm)
(guix store database)
(guix build utils))
(let ((inputs (sql-schema #$schema)
'#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package (let ((inputs
(list sed grep coreutils findutils gawk)) '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(if register-closures? (list guix) '()))) (map canonical-package
(list sed grep coreutils findutils gawk))))
(graphs '#$(match inputs (graphs '#$(match inputs
(((names . _) ...) (((names . _) ...)
names))) names)))
;; This variable is unused but allows us to add INPUTS-TO-COPY ;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs. ;; as inputs.
(to-register (to-register
'#$(map (match-lambda '#$(map (match-lambda
((name thing) thing) ((name thing) thing)
((name thing output) `(,thing ,output))) ((name thing output) `(,thing ,output)))
inputs))) inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(make-iso9660-image #$(bootloader-package bootloader) (make-iso9660-image #$(bootloader-package bootloader)
#$bootcfg-drv #$bootcfg-drv
#$os-drv #$os-drv
"/xchg/guixsd.iso" "/xchg/guixsd.iso"
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:closures graphs #:closures graphs
#:volume-id #$file-system-label #:volume-id #$file-system-label
#:volume-uuid #$(and=> file-system-uuid #:volume-uuid #$(and=> file-system-uuid
uuid-bytevector))))) uuid-bytevector))))))
#:system system #:system system
;; Keep a local file system for /tmp so that we can populate it directly as ;; Keep a local file system for /tmp so that we can populate it directly as
@ -312,90 +347,104 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in register INPUTS in the store database of the image so that Guix can be used in
the image." the image."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema
(and register-closures?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-imported-modules (source-module-closure '((gnu build bootloader) (with-extensions guile-sqlite3&co
(gnu build vm) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
(guix build utils))) (gnu build bootloader)
#~(begin (guix store database)
(use-modules (gnu build bootloader) (guix build utils))
(gnu build vm) #:select? not-config?)
(guix build utils) ((guix config) => ,config))
(srfi srfi-26) #~(begin
(ice-9 binary-ports)) (use-modules (gnu build bootloader)
(gnu build vm)
(guix store database)
(guix build utils)
(srfi srfi-26)
(ice-9 binary-ports))
(let ((inputs (sql-schema #$schema)
'#$(append (list qemu parted e2fsprogs dosfstools)
(map canonical-package
(list sed grep coreutils findutils gawk))
(if register-closures? (list guix) '())))
;; This variable is unused but allows us to add INPUTS-TO-COPY (let ((inputs
;; as inputs. '#$(append (list qemu parted e2fsprogs dosfstools)
(to-register (map canonical-package
'#$(map (match-lambda (list sed grep coreutils findutils gawk))))
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) ;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-register
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs)))
(let* ((graphs '#$(match inputs (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(((names . _) ...)
names))) (let* ((graphs '#$(match inputs
(initialize (root-partition-initializer (((names . _) ...)
#:closures graphs names)))
#:copy-closures? #$copy-inputs? (initialize (root-partition-initializer
#:register-closures? #$register-closures? #:closures graphs
#:system-directory #$os-drv)) #:copy-closures? #$copy-inputs?
(root-size #$(if (eq? 'guess disk-image-size) #:register-closures? #$register-closures?
#~(max #:system-directory #$os-drv))
;; Minimum 20 MiB root size (root-size #$(if (eq? 'guess disk-image-size)
(* 20 (expt 2 20)) #~(max
(estimated-partition-size ;; Minimum 20 MiB root size
(map (cut string-append "/xchg/" <>) (* 20 (expt 2 20))
graphs))) (estimated-partition-size
(- disk-image-size (map (cut string-append "/xchg/" <>)
(* 50 (expt 2 20))))) graphs)))
(partitions (- disk-image-size
(append (* 50 (expt 2 20)))))
(list (partition (partitions
(size root-size) (append
(label #$file-system-label) (list (partition
(uuid #$(and=> file-system-uuid (size root-size)
uuid-bytevector)) (label #$file-system-label)
(file-system #$file-system-type) (uuid #$(and=> file-system-uuid
(flags '(boot)) uuid-bytevector))
(initializer initialize))) (file-system #$file-system-type)
;; Append a small EFI System Partition for use with UEFI (flags '(boot))
;; bootloaders if we are not targeting ARM because UEFI (initializer initialize)))
;; support in U-Boot is experimental. ;; Append a small EFI System Partition for use with UEFI
;; ;; bootloaders if we are not targeting ARM because UEFI
;; FIXME: ‘target-arm32?’ may be not operate on the right ;; support in U-Boot is experimental.
;; system/target values. Rewrite using ‘let-system’ when ;;
;; available. ;; FIXME: ‘target-arm32?’ may be not operate on the right
(if #$(target-arm32?) ;; system/target values. Rewrite using ‘let-system’ when
'() ;; available.
(list (partition (if #$(target-arm32?)
;; The standalone grub image is about 10MiB, but '()
;; leave some room for custom or multiple images. (list (partition
(size (* 40 (expt 2 20))) ;; The standalone grub image is about 10MiB, but
(label "GNU-ESP") ;cosmetic only ;; leave some room for custom or multiple images.
;; Use "vfat" here since this property is used (size (* 40 (expt 2 20)))
;; when mounting. The actual FAT-ness is based (label "GNU-ESP") ;cosmetic only
;; on file system size (16 in this case). ;; Use "vfat" here since this property is used
(file-system "vfat") ;; when mounting. The actual FAT-ness is based
(flags '(esp)))))))) ;; on file system size (16 in this case).
(initialize-hard-disk "/dev/vda" (file-system "vfat")
#:partitions partitions (flags '(esp))))))))
#:grub-efi #$grub-efi (initialize-hard-disk "/dev/vda"
#:bootloader-package #:partitions partitions
#$(bootloader-package bootloader) #:grub-efi #$grub-efi
#:bootcfg #$bootcfg-drv #:bootloader-package
#:bootcfg-location #$(bootloader-package bootloader)
#$(bootloader-configuration-file bootloader) #:bootcfg #$bootcfg-drv
#:bootloader-installer #:bootcfg-location
#$(bootloader-installer bootloader)))))) #$(bootloader-configuration-file bootloader)
#:bootloader-installer
#$(bootloader-installer bootloader)))))))
#:system system #:system system
#:make-disk-image? #t #:make-disk-image? #t
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
@ -413,49 +462,41 @@ makes sense when you want to build a GuixSD Docker image that has Guix
installed inside of it. If you don't need Guix (e.g., your GuixSD Docker installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
image just contains a web server that is started by the Shepherd), then you image just contains a web server that is started by the Shepherd), then you
should set REGISTER-CLOSURES? to #f." should set REGISTER-CLOSURES? to #f."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define config (define config
;; (guix config) module for consumption by (guix gcrypt). ;; (guix config) module for consumption by (guix gcrypt).
(scheme-file "gcrypt-config.scm" (make-config.scm #:libgcrypt libgcrypt))
#~(begin
(define-module (guix config)
#:export (%libgcrypt))
;; XXX: Work around <http://bugs.gnu.org/15602>. (define schema
(eval-when (expand load eval) (and register-closures?
(define %libgcrypt (local-file (search-path %load-path
#+(file-append libgcrypt "/lib/libgcrypt")))))) "guix/store/schema.sql"))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz")) (name -> (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph -> "system-graph"))
(define build (define build
(with-extensions (list guile-json) ;for (guix docker) (with-extensions (cons guile-json ;for (guix docker)
guile-sqlite3&co) ;for (guix store database)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
'((guix docker) '((guix docker)
(guix store database)
(guix build utils) (guix build utils)
(guix build store-copy)
(gnu build vm)) (gnu build vm))
#:select? not-config?) #:select? not-config?)
(guix build store-copy)
((guix config) => ,config)) ((guix config) => ,config))
#~(begin #~(begin
(use-modules (guix docker) (use-modules (guix docker)
(guix build utils) (guix build utils)
(gnu build vm) (gnu build vm)
(srfi srfi-19) (srfi srfi-19)
(guix build store-copy)) (guix build store-copy)
(guix store database))
(let* ((inputs '#$(append (list tar) ;; Set the SQL schema location.
(if register-closures? (sql-schema #$schema)
(list guix)
'()))) (let* (;; This initializer requires elevated privileges that are
;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g., ;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain ;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM. ;; such privileges, we run it as root in a VM.
@ -470,7 +511,7 @@ should set REGISTER-CLOSURES? to #f."
;; lack of privileges if we use a root-directory that is on ;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp). ;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root")) (root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
(mkdir root-directory) (mkdir root-directory)
(initialize root-directory) (initialize root-directory)
(build-docker-image (build-docker-image

209
guix/scripts/pack.scm
View File

@ -35,6 +35,7 @@
#:use-module (guix search-paths) #:use-module (guix search-paths)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix scripts build) #:use-module (guix scripts build)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
@ -101,113 +102,133 @@ with a properly initialized store database.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." added to the pack."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
(define libgcrypt
(module-ref (resolve-interface '(gnu packages gnupg))
'libgcrypt))
(define schema
(and localstatedir?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules `(((guix config)
'((guix build utils) => ,(make-config.scm
(guix build union) #:libgcrypt libgcrypt))
(guix build store-copy) ,@(source-module-closure
(gnu build install))) `((guix build utils)
#~(begin (guix build union)
(use-modules (guix build utils) (guix build store-copy)
((guix build union) #:select (relative-file-name)) (gnu build install))
(gnu build install) #:select? not-config?))
(srfi srfi-1) (with-extensions (cons guile-sqlite3
(srfi srfi-26) (package-transitive-propagated-inputs
(ice-9 match)) guile-sqlite3))
#~(begin
(use-modules (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 %root "root")
(define symlink->directives (define symlink->directives
;; Return "populate directives" to make the given symlink and its ;; Return "populate directives" to make the given symlink and its
;; parent directories. ;; parent directories.
(match-lambda (match-lambda
((source '-> target) ((source '-> target)
(let ((target (string-append #$profile "/" target)) (let ((target (string-append #$profile "/" target))
(parent (dirname source))) (parent (dirname source)))
;; Never add a 'directory' directive for "/" so as to ;; Never add a 'directory' directive for "/" so as to
;; preserve its ownnership when extracting the archive (see ;; preserve its ownnership when extracting the archive (see
;; below), and also because this would lead to adding the ;; below), and also because this would lead to adding the
;; same entries twice in the tarball. ;; same entries twice in the tarball.
`(,@(if (string=? parent "/") `(,@(if (string=? parent "/")
'() '()
`((directory ,parent))) `((directory ,parent)))
(,source (,source
-> ,(relative-file-name parent target))))))) -> ,(relative-file-name parent target)))))))
(define directives (define directives
;; Fully-qualified symlinks. ;; Fully-qualified symlinks.
(append-map symlink->directives '#$symlinks)) (append-map symlink->directives '#$symlinks))
;; The --sort option was added to GNU tar in version 1.28, released ;; The --sort option was added to GNU tar in version 1.28, released
;; 2014-07-28. For testing, we use the bootstrap tar, which is ;; 2014-07-28. For testing, we use the bootstrap tar, which is
;; older and doesn't support it. ;; older and doesn't support it.
(define tar-supports-sort? (define tar-supports-sort?
(zero? (system* (string-append #+archiver "/bin/tar") (zero? (system* (string-append #+archiver "/bin/tar")
"cf" "/dev/null" "--files-from=/dev/null" "cf" "/dev/null" "--files-from=/dev/null"
"--sort=name"))) "--sort=name")))
;; We need Guix here for 'guix-register'. ;; Add 'tar' to the search path.
(setenv "PATH" (setenv "PATH" #+(file-append archiver "/bin"))
(string-append #$(if localstatedir?
(file-append guix "/sbin:")
"")
#$archiver "/bin"))
;; Note: there is not much to gain here with deduplication and there ;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off. ;; is the overhead of the '.links' directory, so turn it off.
;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
;; with hard links: ;; with hard links:
;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
(populate-single-profile-directory %root (populate-single-profile-directory %root
#:profile #$profile #:profile #$profile
#:closure "profile" #:closure "profile"
#:deduplicate? #f #:deduplicate? #f
#:register? #$localstatedir?) #:register? #$localstatedir?
#:schema #$schema)
;; Create SYMLINKS. ;; Create SYMLINKS.
(for-each (cut evaluate-populate-directive <> %root) (for-each (cut evaluate-populate-directive <> %root)
directives) directives)
;; Create the tarball. Use GNU format so there's no file name ;; Create the tarball. Use GNU format so there's no file name
;; length limitation. ;; length limitation.
(with-directory-excursion %root (with-directory-excursion %root
(exit (exit
(zero? (apply system* "tar" (zero? (apply system* "tar"
"-I" "-I"
(string-join '#+(compressor-command compressor)) (string-join '#+(compressor-command compressor))
"--format=gnu" "--format=gnu"
;; Avoid non-determinism in the archive. Use ;; Avoid non-determinism in the archive. Use
;; mtime = 1, not zero, because that is what the ;; mtime = 1, not zero, because that is what the
;; daemon does for files in the store (see the ;; daemon does for files in the store (see the
;; 'mtimeStore' constant in local-store.cc.) ;; 'mtimeStore' constant in local-store.cc.)
(if tar-supports-sort? "--sort=name" "--mtime=@1") (if tar-supports-sort? "--sort=name" "--mtime=@1")
"--mtime=@1" ;for files in /var/guix "--mtime=@1" ;for files in /var/guix
"--owner=root:0" "--owner=root:0"
"--group=root:0" "--group=root:0"
"--check-links" "--check-links"
"-cvf" #$output "-cvf" #$output
;; Avoid adding / and /var to the tarball, so ;; Avoid adding / and /var to the tarball, so
;; that the ownership and permissions of those ;; that the ownership and permissions of those
;; directories will not be overwritten when ;; directories will not be overwritten when
;; extracting the archive. Do not include /root ;; extracting the archive. Do not include /root
;; because the root account might have a ;; because the root account might have a
;; different home directory. ;; different home directory.
#$@(if localstatedir? #$@(if localstatedir?
'("./var/guix") '("./var/guix")
'()) '())
(string-append "." (%store-directory)) (string-append "." (%store-directory))
(delete-duplicates (delete-duplicates
(filter-map (match-lambda (filter-map (match-lambda
(('directory directory) (('directory directory)
(string-append "." directory)) (string-append "." directory))
((source '-> _) ((source '-> _)
(string-append "." source)) (string-append "." source))
(_ #f)) (_ #f))
directives))))))))) directives))))))))))
(gexp->derivation (string-append name ".tar" (gexp->derivation (string-append name ".tar"
(compressor-extension compressor)) (compressor-extension compressor))