diff options
| -rw-r--r-- | gnu/build/install.scm | 45 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 1 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 11 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 391 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 233 |
5 files changed, 379 insertions, 302 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9e30c0d23e..6cc678b44b 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,5 +1,5 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build install) + #:use-module (guix store database) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -158,23 +159,31 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory #:directories? #t))) -(define* (register-closure store closure - #:key (deduplicate? #t)) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'. As a side effect, this resets timestamps on store files -and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the -rest of STORE." - (let ((status (apply system* "guix-register" "--prefix" store - (append (if deduplicate? '() '("--no-deduplication")) - (list closure))))) - (unless (zero? status) - (error "failed to register store items" closure)))) +(define* (register-closure prefix closure + #:key + (deduplicate? #t) (reset-timestamps? #t) + (schema (sql-schema))) + "Register CLOSURE in PREFIX, where PREFIX is the directory name of the +target store and CLOSURE is the name of a file containing a reference graph as +produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is +true, reset timestamps on store files and, if DEDUPLICATE? is true, +deduplicates files common to CLOSURE and the rest of PREFIX." + (let ((items (call-with-input-file closure read-reference-graph))) + ;; TODO: Add a procedure to register all of ITEMS at once. + (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 #:key profile closure deduplicate? - register?) + register? schema) "Populate DIRECTORY with a store containing PROFILE, whose closure is given in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY 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? (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate?) + #:deduplicate? deduplicate? + #:schema schema) - ;; XXX: 'guix-register' registers profiles as GC roots but the symlink - ;; target uses $TMPDIR. Fix that. - (delete-file (scope "/var/guix/gcroots/profiles")) + (mkdir-p* "/var/guix/profiles") + (mkdir-p* "/var/guix/gcroots") (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index fa3ce7790d..37639f723a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (for-each (lambda (closure) (register-closure target (string-append "/xchg/" closure) + #:reset-timestamps? copy-closures? #:deduplicate? deduplicate?)) closures) (unless copy-closures? diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 2b5948256a..393dd0df70 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -194,10 +194,15 @@ ;; differs from user to user. (define (%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) - ((module-ref store '%store-prefix)))) + (lambda (variable) + ((variable-ref variable)))) ((getenv "NIX_STORE") => identity) (else diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 94f1c6197a..b505b0cf6b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -34,6 +34,7 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module ((gnu build vm) #:select (qemu-command)) @@ -50,7 +51,6 @@ #:use-module (gnu packages disk) #:use-module (gnu packages zile) #:use-module (gnu packages linux) - #:use-module (gnu packages package-management) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) #:use-module (gnu packages admin) @@ -116,6 +116,19 @@ (options "trans=virtio") (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 #:key (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 pairs, as for `derivation'. The files containing the reference graphs are 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 (program-file "builder-in-linux-vm" exp)) @@ -178,40 +195,44 @@ made available under the /xchg CIFS share." (define builder ;; Code that launches the VM that evaluates EXP. - (with-imported-modules (source-module-closure '((guix build utils) - (gnu build vm))) - #~(begin - (use-modules (guix build utils) - (gnu build vm)) - - (let* ((inputs '#$(list qemu coreutils)) - (linux (string-append #$linux "/" - #$(system-linux-image-file-name))) - (initrd (string-append #$initrd "/initrd")) - (loader #$loader) - (graphs '#$(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f))) - (size #$(if (eq? 'guess disk-image-size) - #~(+ (* 70 (expt 2 20)) ;ESP - (estimated-partition-size graphs)) - disk-image-size))) - - (set-path-environment-variable "PATH" '("bin") inputs) - - (load-in-linux-vm loader - #:output #$output - #:linux linux #:initrd initrd - #:memory-size #$memory-size - #:make-disk-image? #$make-disk-image? - #:single-file-output? #$single-file-output? - ;; FIXME: ‘target-arm32?’ may not operate on - ;; the right system/target values. Rewrite - ;; using ‘let-system’ when available. - #:target-arm32? #$(target-arm32?) - #:disk-image-format #$disk-image-format - #:disk-image-size size - #:references-graphs graphs))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure + '((guix build utils) + (gnu build vm)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + + (let* ((inputs '#$(list qemu (canonical-package coreutils))) + (linux (string-append #$linux "/" + #$(system-linux-image-file-name))) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f))) + (size #$(if (eq? 'guess disk-image-size) + #~(+ (* 70 (expt 2 20)) ;ESP + (estimated-partition-size graphs)) + disk-image-size))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:single-file-output? #$single-file-output? + ;; FIXME: ‘target-arm32?’ may not operate on + ;; the right system/target values. Rewrite + ;; using ‘let-system’ when available. + #:target-arm32? #$(target-arm32?) + #:disk-image-format #$disk-image-format + #:disk-image-size size + #:references-graphs graphs)))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. @@ -234,42 +255,56 @@ made available under the /xchg CIFS share." "Return a bootable, stand-alone iso9660 image. 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 name - (with-imported-modules (source-module-closure '((gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted e2fsprogs dosfstools xorriso) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - - (graphs '#$(match inputs - (((names . _) ...) - names))) - ;; 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))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (make-iso9660-image #$(bootloader-package bootloader) - #$bootcfg-drv - #$os-drv - "/xchg/guixsd.iso" - #:register-closures? #$register-closures? - #:closures graphs - #:volume-id #$file-system-label - #:volume-uuid #$(and=> file-system-uuid - uuid-bytevector))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build vm) + (guix store database) + (guix build utils)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools xorriso) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + + (graphs '#$(match inputs + (((names . _) ...) + names))) + ;; 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))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-iso9660-image #$(bootloader-package bootloader) + #$bootcfg-drv + #$os-drv + "/xchg/guixsd.iso" + #:register-closures? #$register-closures? + #:closures graphs + #:volume-id #$file-system-label + #:volume-uuid #$(and=> file-system-uuid + uuid-bytevector)))))) #:system system ;; 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, register INPUTS in the store database of the image so that Guix can be used in 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 name - (with-imported-modules (source-module-closure '((gnu build bootloader) - (gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build bootloader) - (gnu build vm) - (guix build utils) - (srfi srfi-26) - (ice-9 binary-ports)) - - (let ((inputs - '#$(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 - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let* ((graphs '#$(match inputs - (((names . _) ...) - names))) - (initialize (root-partition-initializer - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:system-directory #$os-drv)) - (root-size #$(if (eq? 'guess disk-image-size) - #~(max - ;; Minimum 20 MiB root size - (* 20 (expt 2 20)) - (estimated-partition-size - (map (cut string-append "/xchg/" <>) - graphs))) - (- disk-image-size - (* 50 (expt 2 20))))) - (partitions - (append - (list (partition - (size root-size) - (label #$file-system-label) - (uuid #$(and=> file-system-uuid - uuid-bytevector)) - (file-system #$file-system-type) - (flags '(boot)) - (initializer initialize))) - ;; Append a small EFI System Partition for use with UEFI - ;; bootloaders if we are not targeting ARM because UEFI - ;; support in U-Boot is experimental. - ;; - ;; FIXME: ‘target-arm32?’ may be not operate on the right - ;; system/target values. Rewrite using ‘let-system’ when - ;; available. - (if #$(target-arm32?) - '() - (list (partition - ;; The standalone grub image is about 10MiB, but - ;; leave some room for custom or multiple images. - (size (* 40 (expt 2 20))) - (label "GNU-ESP") ;cosmetic only - ;; Use "vfat" here since this property is used - ;; when mounting. The actual FAT-ness is based - ;; on file system size (16 in this case). - (file-system "vfat") - (flags '(esp)))))))) - (initialize-hard-disk "/dev/vda" - #:partitions partitions - #:grub-efi #$grub-efi - #:bootloader-package - #$(bootloader-package bootloader) - #:bootcfg #$bootcfg-drv - #:bootcfg-location - #$(bootloader-configuration-file bootloader) - #:bootloader-installer - #$(bootloader-installer bootloader)))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (gnu build bootloader) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build bootloader) + (gnu build vm) + (guix store database) + (guix build utils) + (srfi srfi-26) + (ice-9 binary-ports)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + ;; 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))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let* ((graphs '#$(match inputs + (((names . _) ...) + names))) + (initialize (root-partition-initializer + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:system-directory #$os-drv)) + (root-size #$(if (eq? 'guess disk-image-size) + #~(max + ;; Minimum 20 MiB root size + (* 20 (expt 2 20)) + (estimated-partition-size + (map (cut string-append "/xchg/" <>) + graphs))) + (- disk-image-size + (* 50 (expt 2 20))))) + (partitions + (append + (list (partition + (size root-size) + (label #$file-system-label) + (uuid #$(and=> file-system-uuid + uuid-bytevector)) + (file-system #$file-system-type) + (flags '(boot)) + (initializer initialize))) + ;; Append a small EFI System Partition for use with UEFI + ;; bootloaders if we are not targeting ARM because UEFI + ;; support in U-Boot is experimental. + ;; + ;; FIXME: ‘target-arm32?’ may be not operate on the right + ;; system/target values. Rewrite using ‘let-system’ when + ;; available. + (if #$(target-arm32?) + '() + (list (partition + ;; The standalone grub image is about 10MiB, but + ;; leave some room for custom or multiple images. + (size (* 40 (expt 2 20))) + (label "GNU-ESP") ;cosmetic only + ;; Use "vfat" here since this property is used + ;; when mounting. The actual FAT-ness is based + ;; on file system size (16 in this case). + (file-system "vfat") + (flags '(esp)))))))) + (initialize-hard-disk "/dev/vda" + #:partitions partitions + #:grub-efi #$grub-efi + #:bootloader-package + #$(bootloader-package bootloader) + #:bootcfg #$bootcfg-drv + #:bootcfg-location + #$(bootloader-configuration-file bootloader) + #:bootloader-installer + #$(bootloader-installer bootloader))))))) #:system system #:make-disk-image? #t #: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 image just contains a web server that is started by the Shepherd), then you should set REGISTER-CLOSURES? to #f." - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - (define config ;; (guix config) module for consumption by (guix gcrypt). - (scheme-file "gcrypt-config.scm" - #~(begin - (define-module (guix config) - #:export (%libgcrypt)) + (make-config.scm #:libgcrypt libgcrypt)) - ;; XXX: Work around <http://bugs.gnu.org/15602>. - (eval-when (expand load eval) - (define %libgcrypt - #+(file-append libgcrypt "/lib/libgcrypt")))))) + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (name -> (string-append name ".tar.gz")) (graph -> "system-graph")) (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 '((guix docker) + (guix store database) (guix build utils) + (guix build store-copy) (gnu build vm)) #:select? not-config?) - (guix build store-copy) ((guix config) => ,config)) #~(begin (use-modules (guix docker) (guix build utils) (gnu build vm) (srfi srfi-19) - (guix build store-copy)) + (guix build store-copy) + (guix store database)) + + ;; Set the SQL schema location. + (sql-schema #$schema) - (let* ((inputs '#$(append (list tar) - (if register-closures? - (list guix) - '()))) - ;; This initializer requires elevated privileges that are + (let* (;; This initializer requires elevated privileges that are ;; not normally available in the build environment (e.g., ;; it needs to create device nodes). In order to obtain ;; 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 ;; a file system that is shared with the host (e.g., /tmp). (root-directory "/guixsd-system-root")) - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) (mkdir root-directory) (initialize root-directory) (build-docker-image diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78bfd01eff..ed876b2592 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -35,6 +35,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #: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 added to the pack." - (define build - (with-imported-modules (source-module-closure - '((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install))) - #~(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 not-config? + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) - (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 ownnership 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))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; 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 - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; We need Guix here for 'guix-register'. - (setenv "PATH" - (string-append #$(if localstatedir? - (file-append guix "/sbin:") - "") - #$archiver "/bin")) - - ;; 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-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir?) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives))))))))) + (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 + (with-imported-modules `(((guix config) + => ,(make-config.scm + #:libgcrypt libgcrypt)) + ,@(source-module-closure + `((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install)) + #:select? not-config?)) + (with-extensions (cons guile-sqlite3 + (package-transitive-propagated-inputs + 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 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 ownnership 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))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; 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 + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; 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-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f + #:register? #$localstatedir? + #:schema #$schema) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + "-I" + (string-join '#+(compressor-command compressor)) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives)))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) |