[bug#30572] [PATCH 1/7] tests: Add tests for "guix pack".

[bug#30572] [PATCH 1/7] tests: Add tests for "guix pack".

[Chris Marusich]

* Makefile.am (SH_TESTS): Add guix-pack.sh.
* tests/guix-pack.sh: New file.
---
 Makefile.am        |  1 +
 tests/guix-pack.sh | 43 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 44 insertions(+)
 create mode 100644 tests/guix-pack.sh

diff --git a/Makefile.am b/Makefile.am
index e2c940ca8..c4c37e327 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -372,6 +372,7 @@ SH_TESTS =					\
   tests/guix-download.sh			\
   tests/guix-gc.sh				\
   tests/guix-hash.sh				\
+  tests/guix-pack.sh				\
   tests/guix-package.sh				\
   tests/guix-package-net.sh			\
   tests/guix-system.sh				\
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
new file mode 100644
index 000000000..00c925666
--- /dev/null
+++ b/tests/guix-pack.sh
@@ -0,0 +1,43 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+#
+# This file is part of GNU Guix.
+#
+# GNU Guix is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# GNU Guix is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+#
+# Test the `guix pack' command-line utility.
+#
+
+guix pack --version
+
+# Use --no-substitutes because we need to verify we can do this ourselves.
+# Use --dry-run because it takes too long to actually build everything.
+GUIX_BUILD_OPTIONS="--no-substitutes --dry-run"
+export GUIX_BUILD_OPTIONS
+
+# Build a tarball.
+guix pack coreutils
+
+# Build a tarball with a symlink.
+guix pack -S /opt/gnu/bin=bin coreutils
+
+# Build a Docker image.
+guix pack -f docker coreutils
+
+# Build a Docker image with a symlink.
+guix pack -f docker -S /opt/gnu=/ coreutils
+
+# Build a tarball pack of cross-compiled software.
+guix pack --target=arm-unknown-linux-gnueabihf coreutils
-- 
2.15.1

[bug#30572] [PATCH 2/7] vm: Allow control of deduplication in root-partition-initializer.

[Chris Marusich]

* gnu/build/vm.scm (root-partition-initializer): Add #:deduplicate?
  keyword argument.
---
 gnu/build/vm.scm | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index fe003ea45..6196b56ca 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -318,11 +318,14 @@ it, run its initializer, and unmount it."
 (define* (root-partition-initializer #:key (closures '())
                                      copy-closures?
                                      (register-closures? #t)
-                                     system-directory)
+                                     system-directory
+                                     (deduplicate? #t))
   "Return a procedure to initialize a root partition.
 
-If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
-store.  If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
+If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
+store.  If DEDUPLICATE? is true, then also deduplicate files common to
+CLOSURES and the rest of the store when registering the closures.  If
+COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
   (lambda (target)
     (define target-store
@@ -347,7 +350,8 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
       (display "registering closures...\n")
       (for-each (lambda (closure)
                   (register-closure target
-                                    (string-append "/xchg/" closure)))
+                                    (string-append "/xchg/" closure)
+                                    #:deduplicate? deduplicate?))
                 closures)
       (unless copy-closures?
         (umount target-store)))
-- 
2.15.1

[bug#30572] [PATCH 3/7] system: Allow customization of the initrd's Guile.

[Chris Marusich]

* gnu/system/linux-initrd.scm (raw-initrd, base-initrd): Add the #:guile
  keyword argument.
* doc/guix.texi (Initial Ram Disk) <base-initrd, raw-initrd>: Update
  their documentation.
---
 doc/guix.texi               | 40 +++++++++++++++++++++++-----------------
 gnu/system/linux-initrd.scm | 31 ++++++++++++++++++++++---------
 2 files changed, 45 insertions(+), 26 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7ed39ff13..5e8c27486 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -18849,33 +18849,39 @@ here is how to use it and customize it further.
 @cindex initrd
 @cindex initial RAM disk
 @deffn {Monadic Procedure} raw-initrd @var{file-systems} @
+       [#:linux linux-libre]
        [#:linux-modules '()] [#:mapped-devices '()] @
-       [#:helper-packages '()] [#:qemu-networking? #f] [#:volatile-root? #f]
-Return a monadic derivation that builds a raw initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd, possibly in addition to
-the root file system specified on the kernel command line via @code{--root}.
-@var{linux-modules} is a list of kernel modules to be loaded at boot time.
-@var{mapped-devices} is a list of device mappings to realize before
-@var{file-systems} are mounted (@pxref{Mapped Devices}).
-@var{helper-packages} is a list of packages to be copied in the initrd. It may
-include @code{e2fsck/static} or other packages needed by the initrd to check
-the root file system.
+       [#:helper-packages '()] [#:guile %guile-static-stripped]
+       [#:qemu-networking? #f] [#:volatile-root? #f]
+Return a monadic derivation that builds a raw initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd, possibly in addition to the root
+file system specified on the kernel command line via @code{--root}.
+@var{linux-modules} is a list of kernel modules to be loaded at boot
+time.  @var{mapped-devices} is a list of device mappings to realize
+before @var{file-systems} are mounted (@pxref{Mapped Devices}).
+@var{helper-packages} is a list of packages to be copied in the
+initrd. It may include @code{e2fsck/static} or other packages needed by
+the initrd to check root partition.  @var{guile} is the Guile to use in
+the initrd.
 
 When @var{qemu-networking?} is true, set up networking with the standard QEMU
-parameters.  When @var{virtio?} is true, load additional modules so that the
-initrd can be used as a QEMU guest with para-virtualized I/O drivers.
+parameters.
 
 When @var{volatile-root?} is true, the root file system is writable but any changes
 to it are lost.
 @end deffn
 
 @deffn {Monadic Procedure} base-initrd @var{file-systems} @
-       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
+       [#:linux linux-libre]
+       [#:mapped-devices '()] [#:guile %guile-static-stripped]
+       [#:qemu-networking? #f] [#:volatile-root? #f]@
        [#:virtio? #t] [#:extra-modules '()]
-Return a monadic derivation that builds a generic initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd like for @code{raw-initrd}.
-@var{mapped-devices}, @var{qemu-networking?} and @var{volatile-root?}
-also behaves as in @code{raw-initrd}.
+Return a monadic derivation that builds a generic initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd like for @code{raw-initrd}.
+@var{mapped-devices}, @var{guile}, @var{qemu-networking?} and
+@var{volatile-root?} also behave as in @code{raw-initrd}.
 
 When @var{virtio?} is true, load additional modules so that the
 initrd can be used as a QEMU guest with para-virtualized I/O drivers.
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 330438bce..aa2f1ae29 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -154,17 +154,18 @@ MODULES and taken from LINUX."
                       (linux-modules '())
                       (mapped-devices '())
                       (helper-packages '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (on-error 'debug))
-  "Return a monadic derivation that builds a raw initrd, with kernel
-modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
-mounted by the initrd, possibly in addition to the root file system specified
-on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
-modules to be loaded at boot time. MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
-HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
-e2fsck/static or other packages needed by the initrd to check root partition.
+  "Return a monadic derivation that builds a raw initrd, with kernel modules
+taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be mounted by the
+initrd, possibly in addition to the root file system specified on the kernel
+command line via '--root'.  LINUX-MODULES is a list of kernel modules to be
+loaded at boot time.  MAPPED-DEVICES is a list of device mappings to realize
+before FILE-SYSTEMS are mounted.  HELPER-PACKAGES is a list of packages to be
+copied in the initrd. It may include e2fsck/static or other packages needed by
+the initrd to check root partition.  GUILE is the Guile to use in the initrd.
 
 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 parameters.
@@ -221,9 +222,15 @@ upon error."
                       #:linux-modules '#$linux-modules
                       #:linux-module-directory '#$kodir
                       #:qemu-guest-networking? #$qemu-networking?
+<<<<<<< HEAD
                       #:volatile-root? '#$volatile-root?
                       #:on-error '#$on-error)))
    #:name "raw-initrd"))
+=======
+                      #:volatile-root? '#$volatile-root?)))
+   #:name "raw-initrd"
+   #:guile guile))
+>>>>>>> system: Allow customization of the initrd's Guile.
 
 (define* (file-system-packages file-systems #:key (volatile-root? #f))
   "Return the list of statically-linked, stripped packages to check
@@ -246,6 +253,7 @@ FILE-SYSTEMS."
                       #:key
                       (linux linux-libre)
                       (mapped-devices '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (virtio? #t)
@@ -255,7 +263,8 @@ FILE-SYSTEMS."
 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 mounted by the initrd, possibly in addition to the root file system specified
 on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
+mappings to realize before FILE-SYSTEMS are mounted.  GUILE is the Guile to
+use in the initrd.
 
 QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
 
@@ -325,6 +334,10 @@ loaded at boot time in the order in which they appear."
               #:helper-packages helper-packages
               #:qemu-networking? qemu-networking?
               #:volatile-root? volatile-root?
+<<<<<<< HEAD
               #:on-error on-error))
+=======
+              #:guile guile))
+>>>>>>> system: Allow customization of the initrd's Guile.
 
 ;;; linux-initrd.scm ends here
-- 
2.15.1

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Chris Marusich]

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..693b4426f 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp"))
   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 contains the closure of PATH, as specified in CLOSURE (a file produced by
 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
@@ -115,8 +116,13 @@ to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
 binaries at PATH are for; it is used to produce metadata in the image.
 
 Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
-CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((directory (string-append tmpdir "/docker-image")) ;temporary working directory
         (closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
-- 
2.15.1

[bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.

[Chris Marusich]

* guix/docker.scm (build-docker-image): Add #:extra-items-dir keyword
  argument.
---
 guix/docker.scm | 21 ++++++++++++++++-----
 1 file changed, 16 insertions(+), 5 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 693b4426f..1b9b36a3b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -107,7 +107,8 @@ return \"a\"."
                              (symlinks '())
                              (system (utsname:machine (uname)))
                              (creation-time (current-time time-utc))
-                             (tmpdir "/tmp"))
+                             (tmpdir "/tmp")
+                             extra-items-dir)
   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 contains the closure of PATH, as specified in CLOSURE (a file produced by
 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
@@ -121,7 +122,12 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
 TMPDIR is the name of the temporary working directory to use.  This can be
 useful if you need to use a specific temporary directory, for example because
 the default temporary directory lies on a file system with insufficient
-space."
+space.
+
+EXTRA-ITEMS-DIR is the name of a directory containing extra files to add to
+the image; the entire directory tree rooted at EXTRA-ITEMS-DIR will be copied
+into the root directory of the image, so a file EXTRA-ITEMS-DIR/foo will wind
+up at /foo in the final Docker image."
   (let ((directory (string-append tmpdir "/docker-image")) ;temporary working directory
         (closure (canonicalize-path closure))
         (id (docker-id path))
@@ -165,9 +171,14 @@ space."
                                   (append %tar-determinism-options
                                           items
                                           (map symlink-source symlinks))))
-                    (for-each delete-file-recursively
-                              (map (compose topmost-component symlink-source)
-                                   symlinks)))))
+                    (begin
+                      (for-each delete-file-recursively
+                                (map (compose topmost-component symlink-source)
+                                     symlinks))
+                      (zero? (apply system* "tar" "-C" extra-items-dir
+                                    "-rf" "layer.tar"
+                                    (append %tar-determinism-options
+                                            '("."))))))))
 
            (with-output-to-file "config.json"
              (lambda ()
-- 
2.15.1

[bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.

[Chris Marusich]

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  34 ++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 116 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  10 ++-
 4 files changed, 200 insertions(+), 7 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 5e8c27486..ea39642c9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -19282,10 +19282,14 @@ size of the image.
 
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -19303,6 +19307,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker-run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 345cecedd..08f33b462 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -22,6 +22,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -29,14 +30,18 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
 
   #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
+
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -73,6 +78,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -366,6 +372,116 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+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 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))
+
+                     ;; XXX: Work around <http://bugs.gnu.org/15602>.
+                     (eval-when (expand load eval)
+                       (define %libgcrypt
+                         #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
+  (define json
+    ;; Pick the guile-json package that corresponds to the Guile used to build
+    ;; derivations.
+    (if (string-prefix? "2.0" (package-version (default-guile)))
+        guile2.0-json
+        guile-json))
+
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (system-graph-name -> "system")
+                      ;; Use a Guile that supports dlopen because it needs to
+                      ;; dlopen libgcrypt in the initrd.  See:
+                      ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+                      (initrd (base-initrd %linux-vm-file-systems
+                                           #:virtio? #t
+                                           #:guile guile-2.2)))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (gnu build vm)
+                                                          (guix build utils)
+                                                          (guix build syscalls))
+                                                        #:select? not-config?)
+                               ((guix config) => ,config))
+        #~(begin
+            ;; Guile-JSON is required by (guix docker).
+            (add-to-load-path
+             (string-append #+json "/share/guile/site/"
+                            (effective-version)))
+            (use-modules (gnu build vm)
+                         (guix build utils)
+                         (guix build syscalls)
+                         (srfi srfi-26)
+                         (ice-9 match)
+                         (guix docker)
+                         (srfi srfi-19))
+
+            (let* ((inputs
+                    '#$(append (list tree parted e2fsprogs dosfstools tar)
+                               (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 '#$os-drv)
+                   (initialize (root-partition-initializer
+                                #:closures '(#$system-graph-name)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   (root "/tmp/root"))
+
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir-p root)
+              (initialize root)
+              ;; Use a temporary directory inside xchg to avoid hitting space
+              ;; limitations in the initrd's root file system.
+              (let ((tmpdir "/xchg/tmp"))
+                (mkdir tmpdir)
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 #$os-drv
+                 #:closure (string-append "/xchg/" #$system-graph-name)
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:tmpdir tmpdir
+                 #:extra-items-dir root)
+                (delete-file-recursively tmpdir))))))
+    (expression->derivation-in-linux-vm
+     name
+     build
+     #:initrd initrd
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,system-graph-name ,os-drv))
+     ;; Our larger initrd requires more memory.
+     #:memory-size 512)))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010..20919d1b1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,9 @@ procedure of its type."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -867,6 +869,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1098,7 +1102,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1127,7 +1131,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1

[bug#30572] [PATCH 7/7] tests: Add tests for "guix system disk-image" et al.

[Chris Marusich]

* tests/guix-system.sh: Add test cases that exercise (1) all of the example
  files in gnu/system/examples, and (2) all of the "image" creation commands:
  vm, vm-image, disk-image, and docker-image.
---
 tests/guix-system.sh | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index ed8563c8a..13907934f 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -267,3 +267,16 @@ guix system build "$tmpdir/config.scm" -n
 # Searching.
 guix system search tor | grep "^name: tor"
 guix system search anonym network | grep "^name: tor"
+
+# Verify the example files.
+for example in gnu/system/examples/*; do
+    guix system -d disk-image -d $example
+done
+
+# Verify the disk image types.
+guix system -d vm gnu/system/examples/vm-image.tmpl
+guix system -d vm-image gnu/system/examples/vm-image.tmpl
+# This invocation was taken care of in the loop above:
+# guix system -d disk-image gnu/system/examples/bare-bones.tmpl
+guix system -d disk-image --file-system-type=iso9660 gnu/system/examples/bare-bones.tmpl
+guix system -d docker-image gnu/system/examples/docker-image.tmpl
-- 
2.15.1

[bug#30572] [PATCH 3/7] system: Allow customization of the initrd's Guile.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 954 bytes --]

Chris Marusich <cmmarusich@gmail.com> writes:

> +<<<<<<< HEAD
>                        #:volatile-root? '#$volatile-root?
>                        #:on-error '#$on-error)))
>     #:name "raw-initrd"))
> +=======
> +                      #:volatile-root? '#$volatile-root?)))
> +   #:name "raw-initrd"
> +   #:guile guile))
> +>>>>>>> system: Allow customization of the initrd's Guile.
>
> ...
>
> +<<<<<<< HEAD
>                #:on-error on-error))
> +=======
> +              #:guile guile))
> +>>>>>>> system: Allow customization of the initrd's Guile.

This is obviously not correct.  I accidentally forgot to resolve these
conflicts when rebasing my branch onto origin/master.  Please disregard
patch 3/7 in favor of the attached patch, which resolves the conflicts.

I've verified (for sure, this time!) that this patch series builds
successfully after it has been applied.  Sorry for the additional churn!

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0003-system-Allow-customization-of-the-initrd-s-Guile.patch --]
[-- Type: text/x-patch, Size: 7505 bytes --]

From 44a4d91853c5c83f6ac32d16d16fab1c342d3b4e Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 04:47:42 +0100
Subject: [PATCH] system: Allow customization of the initrd's Guile.

* gnu/system/linux-initrd.scm (raw-initrd, base-initrd): Add the #:guile
  keyword argument.
* doc/guix.texi (Initial Ram Disk) <base-initrd, raw-initrd>: Update
  their documentation.
---
 doc/guix.texi               | 40 +++++++++++++++++++++++-----------------
 gnu/system/linux-initrd.scm | 27 ++++++++++++++++-----------
 2 files changed, 39 insertions(+), 28 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7ed39ff13..5e8c27486 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -18849,33 +18849,39 @@ here is how to use it and customize it further.
 @cindex initrd
 @cindex initial RAM disk
 @deffn {Monadic Procedure} raw-initrd @var{file-systems} @
+       [#:linux linux-libre]
        [#:linux-modules '()] [#:mapped-devices '()] @
-       [#:helper-packages '()] [#:qemu-networking? #f] [#:volatile-root? #f]
-Return a monadic derivation that builds a raw initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd, possibly in addition to
-the root file system specified on the kernel command line via @code{--root}.
-@var{linux-modules} is a list of kernel modules to be loaded at boot time.
-@var{mapped-devices} is a list of device mappings to realize before
-@var{file-systems} are mounted (@pxref{Mapped Devices}).
-@var{helper-packages} is a list of packages to be copied in the initrd. It may
-include @code{e2fsck/static} or other packages needed by the initrd to check
-the root file system.
+       [#:helper-packages '()] [#:guile %guile-static-stripped]
+       [#:qemu-networking? #f] [#:volatile-root? #f]
+Return a monadic derivation that builds a raw initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd, possibly in addition to the root
+file system specified on the kernel command line via @code{--root}.
+@var{linux-modules} is a list of kernel modules to be loaded at boot
+time.  @var{mapped-devices} is a list of device mappings to realize
+before @var{file-systems} are mounted (@pxref{Mapped Devices}).
+@var{helper-packages} is a list of packages to be copied in the
+initrd. It may include @code{e2fsck/static} or other packages needed by
+the initrd to check root partition.  @var{guile} is the Guile to use in
+the initrd.
 
 When @var{qemu-networking?} is true, set up networking with the standard QEMU
-parameters.  When @var{virtio?} is true, load additional modules so that the
-initrd can be used as a QEMU guest with para-virtualized I/O drivers.
+parameters.
 
 When @var{volatile-root?} is true, the root file system is writable but any changes
 to it are lost.
 @end deffn
 
 @deffn {Monadic Procedure} base-initrd @var{file-systems} @
-       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
+       [#:linux linux-libre]
+       [#:mapped-devices '()] [#:guile %guile-static-stripped]
+       [#:qemu-networking? #f] [#:volatile-root? #f]@
        [#:virtio? #t] [#:extra-modules '()]
-Return a monadic derivation that builds a generic initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd like for @code{raw-initrd}.
-@var{mapped-devices}, @var{qemu-networking?} and @var{volatile-root?}
-also behaves as in @code{raw-initrd}.
+Return a monadic derivation that builds a generic initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd like for @code{raw-initrd}.
+@var{mapped-devices}, @var{guile}, @var{qemu-networking?} and
+@var{volatile-root?} also behave as in @code{raw-initrd}.
 
 When @var{virtio?} is true, load additional modules so that the
 initrd can be used as a QEMU guest with para-virtualized I/O drivers.
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 330438bce..301e6cffa 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -154,17 +154,18 @@ MODULES and taken from LINUX."
                       (linux-modules '())
                       (mapped-devices '())
                       (helper-packages '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (on-error 'debug))
-  "Return a monadic derivation that builds a raw initrd, with kernel
-modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
-mounted by the initrd, possibly in addition to the root file system specified
-on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
-modules to be loaded at boot time. MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
-HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
-e2fsck/static or other packages needed by the initrd to check root partition.
+  "Return a monadic derivation that builds a raw initrd, with kernel modules
+taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be mounted by the
+initrd, possibly in addition to the root file system specified on the kernel
+command line via '--root'.  LINUX-MODULES is a list of kernel modules to be
+loaded at boot time.  MAPPED-DEVICES is a list of device mappings to realize
+before FILE-SYSTEMS are mounted.  HELPER-PACKAGES is a list of packages to be
+copied in the initrd. It may include e2fsck/static or other packages needed by
+the initrd to check root partition.  GUILE is the Guile to use in the initrd.
 
 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 parameters.
@@ -223,7 +224,8 @@ upon error."
                       #:qemu-guest-networking? #$qemu-networking?
                       #:volatile-root? '#$volatile-root?
                       #:on-error '#$on-error)))
-   #:name "raw-initrd"))
+   #:name "raw-initrd"
+   #:guile guile))
 
 (define* (file-system-packages file-systems #:key (volatile-root? #f))
   "Return the list of statically-linked, stripped packages to check
@@ -246,6 +248,7 @@ FILE-SYSTEMS."
                       #:key
                       (linux linux-libre)
                       (mapped-devices '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (virtio? #t)
@@ -255,7 +258,8 @@ FILE-SYSTEMS."
 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 mounted by the initrd, possibly in addition to the root file system specified
 on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
+mappings to realize before FILE-SYSTEMS are mounted.  GUILE is the Guile to
+use in the initrd.
 
 QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
 
@@ -325,6 +329,7 @@ loaded at boot time in the order in which they appear."
               #:helper-packages helper-packages
               #:qemu-networking? qemu-networking?
               #:volatile-root? volatile-root?
-              #:on-error on-error))
+              #:on-error on-error
+              #:guile guile))
 
 ;;; linux-initrd.scm ends here
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 2/7] vm: Allow control of deduplication in root-partition-initializer.

[Danny Milosavljevic]

LGTM

[bug#30572] [PATCH 7/7] tests: Add tests for "guix system disk-image" et al.

[Danny Milosavljevic]

LGTM

[bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.

[Danny Milosavljevic]

> +                      (zero? (apply system* "tar" "-C" extra-items-dir
> +                                    "-rf" "layer.tar"
> +                                    (append %tar-determinism-options
> +                                            '("."))))))))

-C is order-sensitive.  Apparently it still doesn't cause layer.tar
to be created inside extra-items-dir (huh...), but for clarity, I'd prefer:

tar -rf layer.tar -C extra-items-dir .

Otherwise LGTM!

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Danny Milosavljevic]

Hmm, I have a slight preference for not magically adding "/docker-image" here
but rather adding it in the caller and in the default.

But LGTM...

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 308 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

> Hmm, I have a slight preference for not magically adding "/docker-image" here
> but rather adding it in the caller and in the default.

Good idea.  Here's a new version of Patch 4/7 which does what you
suggest!  What do you think?

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0004-docker-Allow-the-use-of-a-custom-temporary-directory.patch --]
[-- Type: text/x-patch, Size: 3410 bytes --]

From dcb8dfd9c6c12f585ec9b64fb42489ce5b4fa9ae Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:45:03 +0100
Subject: [PATCH 4/8] docker: Allow the use of a custom temporary directory.

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..305e8273b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp/docker-image"))
   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 contains the closure of PATH, as specified in CLOSURE (a file produced by
 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
@@ -115,9 +116,13 @@ to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
 binaries at PATH are for; it is used to produce metadata in the image.
 
 Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
-CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
         (arch (let-syntax ((cond* (syntax-rules ()
@@ -133,9 +138,9 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
                        ("arm"    "arm")
                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
-    (mkdir directory)
+    (mkdir-p tmpdir)
 
-    (and (with-directory-excursion directory
+    (and (with-directory-excursion tmpdir
            (mkdir id)
            (with-directory-excursion id
              (with-output-to-file "VERSION"
@@ -174,10 +179,10 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
              (lambda ()
                (scm->json (repositories path id)))))
 
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
+         (and (zero? (apply system* "tar" "-C" tmpdir "-cf" image
                             `(,@%tar-determinism-options
                               ,@(if compressor
                                     (list "-I" (string-join compressor))
                                     '())
                               ".")))
-              (begin (delete-file-recursively directory) #t)))))
+              (begin (delete-file-recursively tmpdir) #t)))))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 693 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

>> +                      (zero? (apply system* "tar" "-C" extra-items-dir
>> +                                    "-rf" "layer.tar"
>> +                                    (append %tar-determinism-options
>> +                                            '("."))))))))
>
> -C is order-sensitive.  Apparently it still doesn't cause layer.tar
> to be created inside extra-items-dir (huh...), but for clarity, I'd prefer:
>
> tar -rf layer.tar -C extra-items-dir .

I didn't realize this was the case.  I agree it would be best to reverse
the order here.  I've attached a patch which does this.  How does it
look?

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0005-docker-Allow-the-addition-of-extra-files-into-the-im.patch --]
[-- Type: text/x-patch, Size: 2674 bytes --]

From 5a889e7d8dc6847c2d9a8ae526df7c974688a947 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:53:16 +0100
Subject: [PATCH 5/8] docker: Allow the addition of extra files into the image.

* guix/docker.scm (build-docker-image): Add #:extra-items-dir keyword
  argument.
---
 guix/docker.scm | 17 ++++++++++++++---
 1 file changed, 14 insertions(+), 3 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 305e8273b..ef92714e0 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -107,7 +107,8 @@ return \"a\"."
                              (symlinks '())
                              (system (utsname:machine (uname)))
                              (creation-time (current-time time-utc))
-                             (tmpdir "/tmp/docker-image"))
+                             (tmpdir "/tmp/docker-image")
+                             extra-items-dir)
   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 contains the closure of PATH, as specified in CLOSURE (a file produced by
 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
@@ -121,7 +122,12 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
 TMPDIR is the name of the temporary working directory to use.  This can be
 useful if you need to use a specific temporary directory, for example because
 the default temporary directory lies on a file system with insufficient
-space."
+space.
+
+EXTRA-ITEMS-DIR is the name of a directory containing extra files to add to
+the image; the entire directory tree rooted at EXTRA-ITEMS-DIR will be copied
+into the root directory of the image, so a file EXTRA-ITEMS-DIR/foo will wind
+up at /foo in the final Docker image."
   (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
@@ -166,7 +172,12 @@ space."
                                           (map symlink-source symlinks))))
                     (for-each delete-file-recursively
                               (map (compose topmost-component symlink-source)
-                                   symlinks)))))
+                                   symlinks))
+                    extra-items-dir
+                    (zero? (apply system* "tar" "-rf" "layer.tar"
+                                  "-C" extra-items-dir
+                                  (append %tar-determinism-options
+                                          '(".")))))))
 
            (with-output-to-file "config.json"
              (lambda ()
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 830 bytes --]

Chris Marusich <cmmarusich@gmail.com> writes:

> +              (let ((tmpdir "/xchg/tmp"))
> +                (mkdir tmpdir)
> +                (build-docker-image
> +                 (string-append "/xchg/" #$name) ;; The output file.
> +                 #$os-drv
> +                 #:closure (string-append "/xchg/" #$system-graph-name)
> +                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
> +                 #:creation-time (make-time time-utc 0 1)
> +                 #:tmpdir tmpdir
> +                 #:extra-items-dir root)
> +                (delete-file-recursively tmpdir))))))

I've adjusted this section to take into account the changes I made to
patches earlier in the series.  Please find attached a new Patch 6/7,
which incorporates these minor adjustments.

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0006-system-Add-guix-system-docker-image-command.patch --]
[-- Type: text/x-patch, Size: 14006 bytes --]

From 1b325723f87ac09d4ac0b860f76982a07e14a985 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Tue, 20 Feb 2018 09:12:48 +0100
Subject: [PATCH 6/8] system: Add "guix system docker-image" command.

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  34 ++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 114 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  10 ++-
 4 files changed, 198 insertions(+), 7 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 32e132d87..3a1708e54 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -19294,10 +19294,14 @@ size of the image.
 
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -19315,6 +19319,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker-run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 345cecedd..e9a94019d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -22,6 +22,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -29,14 +30,18 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
 
   #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
+
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -73,6 +78,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -366,6 +372,114 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+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 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))
+
+                     ;; XXX: Work around <http://bugs.gnu.org/15602>.
+                     (eval-when (expand load eval)
+                       (define %libgcrypt
+                         #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
+  (define json
+    ;; Pick the guile-json package that corresponds to the Guile used to build
+    ;; derivations.
+    (if (string-prefix? "2.0" (package-version (default-guile)))
+        guile2.0-json
+        guile-json))
+
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (system-graph-name -> "system")
+                      ;; Use a Guile that supports dlopen because it needs to
+                      ;; dlopen libgcrypt in the initrd.  See:
+                      ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+                      (initrd (base-initrd %linux-vm-file-systems
+                                           #:virtio? #t
+                                           #:guile guile-2.2)))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (gnu build vm)
+                                                          (guix build utils)
+                                                          (guix build syscalls))
+                                                        #:select? not-config?)
+                               ((guix config) => ,config))
+        #~(begin
+            ;; Guile-JSON is required by (guix docker).
+            (add-to-load-path
+             (string-append #+json "/share/guile/site/"
+                            (effective-version)))
+            (use-modules (gnu build vm)
+                         (guix build utils)
+                         (guix build syscalls)
+                         (srfi srfi-26)
+                         (ice-9 match)
+                         (guix docker)
+                         (srfi srfi-19))
+
+            (let* ((inputs
+                    '#$(append (list tree parted e2fsprogs dosfstools tar)
+                               (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 '#$os-drv)
+                   (initialize (root-partition-initializer
+                                #:closures '(#$system-graph-name)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   (root "/tmp/root"))
+
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir-p root)
+              (initialize root)
+              ;; Use a temporary directory inside xchg to avoid hitting space
+              ;; limitations in the initrd's root file system.
+              (let ((tmpdir "/xchg/tmp/docker-image"))
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 #$os-drv
+                 #:closure (string-append "/xchg/" #$system-graph-name)
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:tmpdir tmpdir
+                 #:extra-items-dir root))))))
+    (expression->derivation-in-linux-vm
+     name
+     build
+     #:initrd initrd
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,system-graph-name ,os-drv))
+     ;; Our larger initrd requires more memory.
+     #:memory-size 512)))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010..20919d1b1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,9 @@ procedure of its type."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -867,6 +869,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1098,7 +1102,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1127,7 +1131,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Danny Milosavljevic]

Hi Chris,

On Mon, 26 Feb 2018 17:23:55 +0100
Chris Marusich <cmmarusich@gmail.com> wrote:

> Danny Milosavljevic <dannym@scratchpost.org> writes:
> 
> > Hmm, I have a slight preference for not magically adding "/docker-image" here
> > but rather adding it in the caller and in the default.
> 
> Good idea.  Here's a new version of Patch 4/7 which does what you
> suggest!  What do you think?

+         (and (zero? (apply system* "tar" "-C" tmpdir "-cf" image

Apparently this works as-is, but also here, I'd write

+         (and (zero? (apply system* "tar" "-cf" image "-C" tmpdir

Otherwise LGTM!

[bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.

[Danny Milosavljevic]

LGTM!

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 365 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

> +         (and (zero? (apply system* "tar" "-C" tmpdir "-cf" image
>
> Apparently this works as-is, but also here, I'd write
>
> +         (and (zero? (apply system* "tar" "-cf" image "-C" tmpdir
>
> Otherwise LGTM!

Good catch!  I've attached a new patch that does what you suggest.

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0004-docker-Allow-the-use-of-a-custom-temporary-directory.patch --]
[-- Type: text/x-patch, Size: 3410 bytes --]

From 4bca56cc619e90b1c820c2a7f8f7a5fe1f4a8645 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:45:03 +0100
Subject: [PATCH 4/8] docker: Allow the use of a custom temporary directory.

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..659d228aa 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp/docker-image"))
   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 contains the closure of PATH, as specified in CLOSURE (a file produced by
 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
@@ -115,9 +116,13 @@ to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
 binaries at PATH are for; it is used to produce metadata in the image.
 
 Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
-CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
         (arch (let-syntax ((cond* (syntax-rules ()
@@ -133,9 +138,9 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
                        ("arm"    "arm")
                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
-    (mkdir directory)
+    (mkdir-p tmpdir)
 
-    (and (with-directory-excursion directory
+    (and (with-directory-excursion tmpdir
            (mkdir id)
            (with-directory-excursion id
              (with-output-to-file "VERSION"
@@ -174,10 +179,10 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
              (lambda ()
                (scm->json (repositories path id)))))
 
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
+         (and (zero? (apply system* "tar" "-cf" image "-C" tmpdir
                             `(,@%tar-determinism-options
                               ,@(if compressor
                                     (list "-I" (string-join compressor))
                                     '())
                               ".")))
-              (begin (delete-file-recursively directory) #t)))))
+              (begin (delete-file-recursively tmpdir) #t)))))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 1/7] tests: Add tests for "guix pack".

[Ludovic Courtès]

Hello Chris,

Chris Marusich <cmmarusich@gmail.com> skribis:

> * Makefile.am (SH_TESTS): Add guix-pack.sh.
> * tests/guix-pack.sh: New file.

That’s a great idea, and indeed something that should have been done
earlier on.

Some comments:

> +# Use --dry-run because it takes too long to actually build everything.
> +GUIX_BUILD_OPTIONS="--no-substitutes --dry-run"
> +export GUIX_BUILD_OPTIONS
> +
> +# Build a tarball.
> +guix pack coreutils

It would be ideal if we could actually build something, but built
something cheap.

The way we do that in those tests is by:

  1. Using the ‘guile-bootstrap’ package as an example, under the
     assumption that it’s already available, does not require
     networking, and is built in one or two seconds.

  2. Using ‘--bootstrap’ or a similar option so that the derivations use
     ‘guile-bootstrap’ instead of ‘guile-final’, for the same reason.

See for instance tests/guix-package.sh.

Would you be willing to try something along these lines?

Thanks,
Ludo’.

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Ludovic Courtès]

Hello Chris,

Chris Marusich <cmmarusich@gmail.com> skribis:

> +TMPDIR is the name of the temporary working directory to use.  This can be
> +useful if you need to use a specific temporary directory, for example because
> +the default temporary directory lies on a file system with insufficient
> +space."

Usually this code is used in a derivation, where it doesn’t really
matter which directory is used, no?

Thanks,
Ludo’.

[bug#30572] [PATCH 3/7] system: Allow customization of the initrd's Guile.

[Ludovic Courtès]

Hello!

Chris Marusich <cmmarusich@gmail.com> skribis:

>  @deffn {Monadic Procedure} base-initrd @var{file-systems} @
> -       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
> +       [#:linux linux-libre]
> +       [#:mapped-devices '()] [#:guile %guile-static-stripped]
> +       [#:qemu-networking? #f] [#:volatile-root? #f]@

Nitpick: you need an @ at the end of intermediate lines.  :-)

Otherwise LGTM.

Thanks,
Ludo’.

[bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.

[Ludovic Courtès]

Chris Marusich <cmmarusich@gmail.com> skribis:

> From 5a889e7d8dc6847c2d9a8ae526df7c974688a947 Mon Sep 17 00:00:00 2001
> From: Chris Marusich <cmmarusich@gmail.com>
> Date: Mon, 19 Feb 2018 05:53:16 +0100
> Subject: [PATCH 5/8] docker: Allow the addition of extra files into the image.
>
> * guix/docker.scm (build-docker-image): Add #:extra-items-dir keyword
>   argument.

What about simply changing the existing ‘path’ argument to ‘paths’
(plural)?  Would that work for you?

It would seem more natural to me.

Besides, I think we should keep avoiding abbreviations like “dir” (see
“Formatting Code” in the manual :-)).

Ludo’.

[bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.

[Ludovic Courtès]

Chris Marusich <cmmarusich@gmail.com> skribis:

> +  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))

Since <operating-system> has a gexp compiler, this line is no longer
needed.  Instead you can write:

  #~(do something with #$os)

> +                      (name -> (string-append name ".tar.gz"))
> +                      (system-graph-name -> "system")
> +                      ;; Use a Guile that supports dlopen because it needs to
> +                      ;; dlopen libgcrypt in the initrd.  See:
> +                      ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
> +                      (initrd (base-initrd %linux-vm-file-systems
> +                                           #:virtio? #t
> +                                           #:guile guile-2.2)))

Uh, that must be a big initrd indeed.  :-)

> +    (define build
> +      (with-imported-modules `(,@(source-module-closure '((guix docker)
> +                                                          (gnu build vm)
> +                                                          (guix build utils)
> +                                                          (guix build syscalls))
> +                                                        #:select? not-config?)
> +                               ((guix config) => ,config))
> +        #~(begin
> +            ;; Guile-JSON is required by (guix docker).
> +            (add-to-load-path
> +             (string-append #+json "/share/guile/site/"
> +                            (effective-version)))
> +            (use-modules (gnu build vm)
> +                         (guix build utils)
> +                         (guix build syscalls)
> +                         (srfi srfi-26)
> +                         (ice-9 match)
> +                         (guix docker)
> +                         (srfi srfi-19))
> +
> +            (let* ((inputs
> +                    '#$(append (list tree parted e2fsprogs dosfstools tar)
> +                               (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 '#$os-drv)
> +                   (initialize (root-partition-initializer
> +                                #:closures '(#$system-graph-name)
> +                                #:register-closures? #$register-closures?
> +                                #:system-directory #$os-drv
> +                                ;; De-duplication would fail due to
> +                                ;; cross-device link errors, so don't do it.
> +                                #:deduplicate? #f))
> +                   (root "/tmp/root"))
> +
> +              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
> +              (mkdir-p root)
> +              (initialize root)
> +              ;; Use a temporary directory inside xchg to avoid hitting space
> +              ;; limitations in the initrd's root file system.
> +              (let ((tmpdir "/xchg/tmp/docker-image"))
> +                (build-docker-image
> +                 (string-append "/xchg/" #$name) ;; The output file.
> +                 #$os-drv
> +                 #:closure (string-append "/xchg/" #$system-graph-name)
> +                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
> +                 #:creation-time (make-time time-utc 0 1)
> +                 #:tmpdir tmpdir
> +                 #:extra-items-dir root))))))
> +    (expression->derivation-in-linux-vm
> +     name
> +     build

What about here replacing ‘build’ on the line above with something like:

  #~(execl #$(program-file "build-docker-image.scm" build)
          "build-docker-image")

This would create a ‘build-docker-image.scm’ script that uses the real
Guile 2.2, but we could still use guile-static-stripped in the initrd.

WDYT?

Thanks!

Ludo’.

[bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.

[Chris Marusich]

[-- Attachment #1: Type: text/plain, Size: 1051 bytes --]

Hi Ludo,

Thank you for taking the time to review the patch series!

ludo@gnu.org (Ludovic Courtès) writes:

> Chris Marusich <cmmarusich@gmail.com> skribis:
>
>> +  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
>
> Since <operating-system> has a gexp compiler, this line is no longer
> needed.  Instead you can write:
>
>   #~(do something with #$os)

Will this work even though I need #:container? to be #t?

> What about here replacing ‘build’ on the line above with something like:
>
>   #~(execl #$(program-file "build-docker-image.scm" build)
>           "build-docker-image")
>
> This would create a ‘build-docker-image.scm’ script that uses the real
> Guile 2.2, but we could still use guile-static-stripped in the initrd.
>
> WDYT?

That sounds like a good idea.  I'll look into it and send an update in a
few days.

By the way, if you have any thoughts regarding the questions I asked in
the very first email of this patch series, I'd love to hear them!

-- 
Chris

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 1/7] tests: Add tests for "guix pack".

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 8438 bytes --]

ludo@gnu.org (Ludovic Courtès) writes:

>> +# Use --dry-run because it takes too long to actually build everything.
>> +GUIX_BUILD_OPTIONS="--no-substitutes --dry-run"
>> +export GUIX_BUILD_OPTIONS
>> +
>> +# Build a tarball.
>> +guix pack coreutils
>
> It would be ideal if we could actually build something, but built
> something cheap.
>
> The way we do that in those tests is by:
>
>   1. Using the ‘guile-bootstrap’ package as an example, under the
>      assumption that it’s already available, does not require
>      networking, and is built in one or two seconds.
>
>   2. Using ‘--bootstrap’ or a similar option so that the derivations use
>      ‘guile-bootstrap’ instead of ‘guile-final’, for the same reason.
>
> See for instance tests/guix-package.sh.
>
> Would you be willing to try something along these lines?

That's a good idea!  I tried it (see attached patch).  Unfortunately,
even after adding a --bootstrap option, "guix pack" tries to build many
things, so tests/guix-pack.sh takes hours to run the first time you try
it (it ran for 2 hours on my laptop and then failed because gcc failed
to build for unrelated reasons):

--8<---------------cut here---------------start------------->8---
+ GUIX_BUILD_OPTIONS=--no-substitutes
+ export GUIX_BUILD_OPTIONS
+ guix pack --bootstrap guile-bootstrap
accepted connection from pid 25978, user marusich
The following derivations will be built:
   /home/marusich/guix-wip-docker/test-tmp/store/5306akcwzxpl00jq237i5np684j0vmzl-tarball-pack.tar.gz.drv
   /home/marusich/guix-wip-docker/test-tmp/store/cdvscfg50aw5jxnd259x1h9bp30lfkdj-module-import.drv
   /home/marusich/guix-wip-docker/test-tmp/store/wr7q9d2fzkw1fi6q8ms8fkx9ivxjkqqg-module-import-compiled.drv
   /home/marusich/guix-wip-docker/test-tmp/store/yirhq0bk23hs1ygx0b1ny3v56x9c9fji-tar-1.29.tar.xz.drv
   /home/marusich/guix-wip-docker/test-tmp/store/fwlyz9ll798kzb509zklkqbgf6px4sj9-lzip-1.19.drv
   /home/marusich/guix-wip-docker/test-tmp/store/dncnbczz63kq6zmdrr8vf5h5c2sb71pg-ed-1.14.2.drv
   /home/marusich/guix-wip-docker/test-tmp/store/9fnrsfhfa4sh8fm86s7451gm9lma3ys1-pkg-config-0.29.2.drv
   /home/marusich/guix-wip-docker/test-tmp/store/6vddknc0jvxl6nbqvimn6mdilvxavln4-m4-1.4.18.drv
   /home/marusich/guix-wip-docker/test-tmp/store/ww1wddpxfj4ynbi3gspdnfpi1w6zh19l-expat-2.2.5.drv
   /home/marusich/guix-wip-docker/test-tmp/store/77hapsriz2k7ix77gqgmsj5m2dxzshy3-gettext-minimal-0.19.8.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/kprlkrdl1bmxghi1q53vm4bc3cxfiw61-attr-2.4.47.drv
   /home/marusich/guix-wip-docker/test-tmp/store/93rzrq8dnl74rlfzvv1a4k1m553s7g57-libcap-2.25.drv
   /home/marusich/guix-wip-docker/test-tmp/store/d5kc96m4why9yvnlvyal8qb5ar6gi7sw-perl-5.26.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/w282an05cm2900wv8l7hk51rv1df3kl6-gmp-6.1.2.drv
   /home/marusich/guix-wip-docker/test-tmp/store/xk9l4cnqqc0jq611vm7i5gm5f2zh505n-acl-2.2.52.drv
   /home/marusich/guix-wip-docker/test-tmp/store/32m2qgabizs50hm70rjdc3zx4a64c1sx-libsigsegv-2.11.drv
   /home/marusich/guix-wip-docker/test-tmp/store/0jv6207vr9d8dd1j4ipiqbvgsxxwb9ax-m4-1.4.18.drv
   /home/marusich/guix-wip-docker/test-tmp/store/hdr6lkf7fwv7zgpryd9rnx2n9qqy017q-libatomic-ops-7.4.8.drv
   /home/marusich/guix-wip-docker/test-tmp/store/15kqh766smp6jy64is5zy49yix20l4h9-libltdl-2.4.6.drv
   /home/marusich/guix-wip-docker/test-tmp/store/2amv52bswrhvq82y6cx2dgbbaw1vnq32-libffi-3.2.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/4niik1n2j3f62xv01x5h6jwmzm0f3nvz-libgc-7.6.0.drv
   /home/marusich/guix-wip-docker/test-tmp/store/hy8c34s1q5a0af6jc61z4z3159c8gryq-gmp-6.1.2.drv
   /home/marusich/guix-wip-docker/test-tmp/store/illsqfj4c1zdkszwyyw8b9r593lx8xvx-libunistring-0.9.8.drv
   /home/marusich/guix-wip-docker/test-tmp/store/jz05x01mb6y7i3by3mwzj9bwqnmcvr6m-pkg-config-0.29.2.drv
   /home/marusich/guix-wip-docker/test-tmp/store/rfcacc8gajq6sqvx5166cxal3qqjdv48-perl-boot0-5.26.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/0sy6428wjldm79ksdmgif7ak6j63fsda-module-import.drv
   /home/marusich/guix-wip-docker/test-tmp/store/rglsxbjr8aplljbl87ibqwq32f0zbfz5-module-import-compiled.drv
   /home/marusich/guix-wip-docker/test-tmp/store/vgqjcfc86maww541pvkl8lzhbkayy427-gzip-1.8.drv
   /home/marusich/guix-wip-docker/test-tmp/store/1malkdjyhma8payi1q39gpas819drs7m-module-import.drv
   /home/marusich/guix-wip-docker/test-tmp/store/1n2b3c5drfdmc8ammc4fhhnz6wiqxlfg-tar-1.29.drv
   /home/marusich/guix-wip-docker/test-tmp/store/3rm7z6iwjk36ccw2q2cchn5cy25gpbw9-glibc-utf8-locales-2.26.105-g0890d5379c.drv
   /home/marusich/guix-wip-docker/test-tmp/store/9svg3a4sggjwjh7xjpra68mms3qrnzyy-bash-minimal-4.4.12.drv
   /home/marusich/guix-wip-docker/test-tmp/store/9y3vbqgvzgf3z0a8wrh6n710m2nca3k1-gcc-5.5.0.drv
   /home/marusich/guix-wip-docker/test-tmp/store/av9n8ds39jzxp13h6pzls4wlq62nd1ry-grep-3.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/c1rm58rv7xyhkw5jqw0hljzdwkx87vv4-guile-2.2.3.drv
   /home/marusich/guix-wip-docker/test-tmp/store/cc9nalqm463s7kwz9j093iaph45zmbm1-findutils-4.6.0.drv
   /home/marusich/guix-wip-docker/test-tmp/store/dhz1a4ascsmfypkd1fl782fj1wn75k04-gzip-1.8.drv
   /home/marusich/guix-wip-docker/test-tmp/store/gxgvm9d4x7n72pzfmr8bisq2j2jd5dw9-bzip2-1.0.6.drv
   /home/marusich/guix-wip-docker/test-tmp/store/ixysd07gjzcfi3l7x61n7k4mbyi2mgzl-gawk-4.1.4.drv
   /home/marusich/guix-wip-docker/test-tmp/store/plfrsghh3kk0kjjwsl9qh7mh4ppm4s7j-coreutils-8.28.drv
   /home/marusich/guix-wip-docker/test-tmp/store/plsnrf4f6mfyw5270f3f46hfq9agikxi-make-4.2.1.drv
   /home/marusich/guix-wip-docker/test-tmp/store/q6g6axx4i927mw8jx7kl8brjsxgkwgsp-ld-wrapper-0.drv
   /home/marusich/guix-wip-docker/test-tmp/store/v97fmq5lbcawz4z3ljic971djdif5ayh-xz-5.2.3.drv
   /home/marusich/guix-wip-docker/test-tmp/store/x34halk6yz9nmkd2wcipxgn6fmygdyn8-patch-2.7.5.drv
   /home/marusich/guix-wip-docker/test-tmp/store/xa3a93dyfv3pkkg79jmaz37lb4p57s96-diffutils-3.6.drv
   /home/marusich/guix-wip-docker/test-tmp/store/xyb0kwdmish8a299smx7hkq0fgrfn4qw-sed-4.4.drv
   /home/marusich/guix-wip-docker/test-tmp/store/z0z9f2cxk2za96i8fczq23mh3h70d4n9-file-5.32.drv
   /home/marusich/guix-wip-docker/test-tmp/store/z6ads1hjgrcj5jcaf7jinrh9bn2m7rmk-module-import-compiled.drv
   /home/marusich/guix-wip-docker/test-tmp/store/gqb0hng3ndhgi8ddxnwn1lbi58vpbawl-gzip-1.8.drv
   /home/marusich/guix-wip-docker/test-tmp/store/w9s9c0b8szkkx79qi910r7jjs1zwkzaw-tar-1.29.drv
--8<---------------cut here---------------end--------------->8---

It's quicker after the first time, but it's a hefty one-time cost.

I think so many things need to be built because "guix pack" creates the
pack using a gexp that uses packages.  For example, instead of executing
"tar" by looking it up in the current environment (e.g. via system*), it
builds the "tar" package and executes the resulting "tar" program in the
gexp that creates the pack.  Therefore, even though we do use
guile-bootstrap to run the gexp, Guix still need to build tar and all of
its dependencies, so the test takes hours to run.  Can we do better?

Maybe we could share the host's store with the test.  I don't think this
will help, though, since the package definitions used by the installed
Guix are often different than the package definitions in the Git
repository.  If we tried to do this, I think we'd probably just wind up
building tar etc. before running the test, instead of during the test.
The total time required to prepare and run the test probably wouldn't
change.

Maybe we could move tests like these to a "long-running" test target
(e.g., "make check-long-running").  I think this could work, but I would
much rather just write tests that run quickly.

Maybe we could rewrite "guix pack" so that it uses system* to run tar.
I think this might actually be a good idea, but I'm curious to know what
you think.  It's neat that one can write a program (like "guix pack")
whose runtime dependencies are built just-in-time by Guix.  However,
these runtime dependencies (e.g., tar) could theoretically be garbage
collected by Guix in-between invocations of "guix pack", and it clearly
makes the program a little more difficult to test.

Finally, maybe we could stick with running the tests in "dry-run" mode.
I'm in favor of this idea, but obviously I'm a little biased.  :-)

-- 
Chris

[-- Attachment #1.2: 0001-tests-Add-tests-for-guix-pack.patch --]
[-- Type: text/x-patch, Size: 9074 bytes --]

From 72e672e795fe8f4d67f7e1805ba8b88c874f3fb1 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Tue, 20 Feb 2018 02:17:54 +0100
Subject: [PATCH 1/7] tests: Add tests for "guix pack".

* guix/scripts/pack.scm (%options): Add the --bootstrap option.
  (show-help): Document it.
  (guix-pack): Honor it.
* doc/guix.texi (Invoking guix pack): Document the new --bootstrap
  option.
* tests/guix-pack.sh: New file.
* Makefile.am (SH_TESTS): Add guix-pack.sh.
* gnu/packages/package-management.scm (guix) <inputs>: Add util-linux.
---
 Makefile.am                         |  1 +
 doc/guix.texi                       |  4 +++
 gnu/packages/package-management.scm |  2 ++
 guix/scripts/pack.scm               | 51 ++++++++++++++++++++------------
 tests/guix-pack.sh                  | 59 +++++++++++++++++++++++++++++++++++++
 5 files changed, 98 insertions(+), 19 deletions(-)
 create mode 100644 tests/guix-pack.sh

diff --git a/Makefile.am b/Makefile.am
index e2c940ca8..c4c37e327 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -372,6 +372,7 @@ SH_TESTS =					\
   tests/guix-download.sh			\
   tests/guix-gc.sh				\
   tests/guix-hash.sh				\
+  tests/guix-pack.sh				\
   tests/guix-package.sh				\
   tests/guix-package-net.sh			\
   tests/guix-system.sh				\
diff --git a/doc/guix.texi b/doc/guix.texi
index fb2834942..1d06f6a87 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2894,6 +2894,10 @@ added to it or removed from it after extraction of the pack.
 
 One use case for this is the Guix self-contained binary tarball
 (@pxref{Binary Installation}).
+
+@item --bootstrap
+Use the bootstrap Guile to build the pack.  This option is only useful
+to Guix developers.
 @end table
 
 In addition, @command{guix pack} supports all the common build options
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 32a7a30e7..5e11eaedd 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -257,6 +257,8 @@
          ;; Many tests rely on the 'guile-bootstrap' package, which is why we
          ;; have it here.
          ("boot-guile" ,(bootstrap-guile-origin (%current-system)))
+         ;; Some of the tests use "unshare" when it is available.
+         ("util-linux" ,util-linux)
          ,@(if (and (not (%current-target-system))
                     (string=? (%current-system) "x86_64-linux"))
                `(("boot-guile/i686" ,(bootstrap-guile-origin "i686-linux")))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 59dd117ed..460e9f2f2 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -33,6 +33,7 @@
   #:use-module (guix derivations)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
+  #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages compression)
   #:autoload   (gnu packages base) (tar)
   #:autoload   (gnu packages package-management) (guix)
@@ -325,6 +326,9 @@ the image."
          (option '("localstatedir") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'localstatedir? #t result)))
+         (option '("bootstrap") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'bootstrap? #t result)))
 
          (append %transformation-options
                  %standard-build-options)))
@@ -352,6 +356,8 @@ Create a bundle of PACKAGE.\n"))
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
+  (display (G_ "
+      --bootstrap        use the bootstrap Guile to build the pack"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -393,28 +399,35 @@ Create a bundle of PACKAGE.\n"))
        (else (packages->manifest packages)))))
 
   (with-error-handling
-    (parameterize ((%graft? (assoc-ref opts 'graft?)))
-      (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-             (manifest    (manifest-from-args opts))
-             (pack-format (assoc-ref opts 'format))
-             (name        (string-append (symbol->string pack-format)
-                                         "-pack"))
-             (target      (assoc-ref opts 'target))
-             (compressor  (assoc-ref opts 'compressor))
-             (symlinks    (assoc-ref opts 'symlinks))
-             (build-image (match (assq-ref %formats pack-format)
-                            ((? procedure? proc) proc)
-                            (#f
-                             (leave (G_ "~a: unknown pack format")
-                                    format))))
-             (localstatedir? (assoc-ref opts 'localstatedir?)))
-        (with-store store
-          ;; Set the build options before we do anything else.
-          (set-build-options-from-command-line store opts)
-
+    (let* ((dry-run?    (assoc-ref opts 'dry-run?))
+           (manifest    (manifest-from-args opts))
+           (pack-format (assoc-ref opts 'format))
+           (name        (string-append (symbol->string pack-format)
+                                       "-pack"))
+           (target      (assoc-ref opts 'target))
+           (compressor  (assoc-ref opts 'compressor))
+           (symlinks    (assoc-ref opts 'symlinks))
+           (build-image (match (assq-ref %formats pack-format)
+                          ((? procedure? proc) proc)
+                          (#f
+                           (leave (G_ "~a: unknown pack format")
+                                  format))))
+           (localstatedir? (assoc-ref opts 'localstatedir?))
+           (bootstrap? (assoc-ref opts 'bootstrap?)))
+      (with-store store
+        (parameterize ((%graft? (assoc-ref opts 'graft?))
+                       (%guile-for-build (package-derivation
+                                          store
+                                          (if (assoc-ref opts 'bootstrap?)
+                                              %bootstrap-guile
+                                              (canonical-package guile-2.2)))))
           (run-with-store store
             (mlet* %store-monad ((profile (profile-derivation
                                            manifest
+                                           #:hooks (if bootstrap?
+                                                       '()
+                                                       %default-profile-hooks)
+                                           #:locales? (not bootstrap?)
                                            #:target target))
                                  (drv (build-image name profile
                                                    #:target
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
new file mode 100644
index 000000000..a754324d1
--- /dev/null
+++ b/tests/guix-pack.sh
@@ -0,0 +1,59 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+#
+# This file is part of GNU Guix.
+#
+# GNU Guix is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# GNU Guix is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+#
+# Test the `guix pack' command-line utility.
+#
+
+guix pack --version
+
+# Use --no-substitutes because we need to verify we can do this ourselves.
+GUIX_BUILD_OPTIONS="--no-substitutes"
+export GUIX_BUILD_OPTIONS
+
+# Build a tarball.
+guix pack --bootstrap guile-bootstrap
+
+# Build a tarball with a symlink.
+the_pack="$(guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap)"
+
+is_available () {
+    # Use the "type" shell builtin to see if the program is on PATH.
+    type "$1"
+}
+
+if is_available chroot && is_available unshare; then
+    # Verify we can extract and use it.
+    test_directory="$(mktemp -d)"
+    trap 'rm -rf "$test_directory"' EXIT
+    cd "$test_directory"
+    tar -xf "$the_pack"
+    unshare -mrf chroot . /opt/gnu/bin/guile --version
+    cd -
+else
+    echo "chroot/unshare not available, skipping verification of pack contents"
+fi
+
+# Build a Docker image.
+guix pack --bootstrap -f docker guile-bootstrap
+
+# Build a Docker image with a symlink.
+guix pack --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+
+# Build a tarball pack of cross-compiled software.
+guix pack --bootstrap --target=arm-unknown-linux-gnueabihf guile-bootstrap
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 3/7] system: Allow customization of the initrd's Guile.

[Chris Marusich]

[-- Attachment #1.1: Type: text/plain, Size: 1194 bytes --]

ludo@gnu.org (Ludovic Courtès) writes:

> Chris Marusich <cmmarusich@gmail.com> skribis:
>
>>  @deffn {Monadic Procedure} base-initrd @var{file-systems} @
>> -       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
>> +       [#:linux linux-libre]
>> +       [#:mapped-devices '()] [#:guile %guile-static-stripped]
>> +       [#:qemu-networking? #f] [#:volatile-root? #f]@
>
> Nitpick: you need an @ at the end of intermediate lines.  :-)

Thank you; I appreciate nit-picking, since these are the kinds of things
that are easy to overlook!  I've added the @ symbols (see attached).
However, are they really necessary?

According to (texinfo) Multiple Spaces, inserting an @ followed by a
newline inserts a single space into the output.  That's what we're doing
here, right?  But even when I omit the @ symbols at the end of the
lines, the TexInfo manual builds without error, and the procedure
definition appears to render just fine in the stand-alone Info reader.
Unless the intent here really is to insert just one extra space between
some, but not all, of the arguments, I think we can probably omit all of
these @ symbols.  WDYT?

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0003-system-Allow-customization-of-the-initrd-s-Guile.patch --]
[-- Type: text/x-patch, Size: 7570 bytes --]

From 32c9a237c4db4d42fe6542be0c418b39c3a68aa1 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 04:47:42 +0100
Subject: [PATCH 3/7] system: Allow customization of the initrd's Guile.

* gnu/system/linux-initrd.scm (raw-initrd, base-initrd): Add the #:guile
  keyword argument.
* doc/guix.texi (Initial Ram Disk) <base-initrd, raw-initrd>: Update
  their documentation.
---
 doc/guix.texi               | 42 ++++++++++++++++++++++++------------------
 gnu/system/linux-initrd.scm | 27 ++++++++++++++++-----------
 2 files changed, 40 insertions(+), 29 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fb2834942..adac7530a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -18861,33 +18861,39 @@ here is how to use it and customize it further.
 @cindex initrd
 @cindex initial RAM disk
 @deffn {Monadic Procedure} raw-initrd @var{file-systems} @
-       [#:linux-modules '()] [#:mapped-devices '()] @
-       [#:helper-packages '()] [#:qemu-networking? #f] [#:volatile-root? #f]
-Return a monadic derivation that builds a raw initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd, possibly in addition to
-the root file system specified on the kernel command line via @code{--root}.
-@var{linux-modules} is a list of kernel modules to be loaded at boot time.
-@var{mapped-devices} is a list of device mappings to realize before
-@var{file-systems} are mounted (@pxref{Mapped Devices}).
-@var{helper-packages} is a list of packages to be copied in the initrd. It may
-include @code{e2fsck/static} or other packages needed by the initrd to check
-the root file system.
+       [#:linux linux-libre]@
+       [#:linux-modules '()] [#:mapped-devices '()]@
+       [#:helper-packages '()] [#:guile %guile-static-stripped]@
+       [#:qemu-networking? #f] [#:volatile-root? #f]
+Return a monadic derivation that builds a raw initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd, possibly in addition to the root
+file system specified on the kernel command line via @code{--root}.
+@var{linux-modules} is a list of kernel modules to be loaded at boot
+time.  @var{mapped-devices} is a list of device mappings to realize
+before @var{file-systems} are mounted (@pxref{Mapped Devices}).
+@var{helper-packages} is a list of packages to be copied in the
+initrd. It may include @code{e2fsck/static} or other packages needed by
+the initrd to check root partition.  @var{guile} is the Guile to use in
+the initrd.
 
 When @var{qemu-networking?} is true, set up networking with the standard QEMU
-parameters.  When @var{virtio?} is true, load additional modules so that the
-initrd can be used as a QEMU guest with para-virtualized I/O drivers.
+parameters.
 
 When @var{volatile-root?} is true, the root file system is writable but any changes
 to it are lost.
 @end deffn
 
 @deffn {Monadic Procedure} base-initrd @var{file-systems} @
-       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
+       [#:linux linux-libre] [#:mapped-devices '()]@
+       [#:guile %guile-static-stripped]@
+       [#:qemu-networking? #f] [#:volatile-root? #f]@
        [#:virtio? #t] [#:extra-modules '()]
-Return a monadic derivation that builds a generic initrd.  @var{file-systems} is
-a list of file systems to be mounted by the initrd like for @code{raw-initrd}.
-@var{mapped-devices}, @var{qemu-networking?} and @var{volatile-root?}
-also behaves as in @code{raw-initrd}.
+Return a monadic derivation that builds a generic initrd, with kernel
+modules taken from @var{linux}.  @var{file-systems} is a list of file
+systems to be mounted by the initrd like for @code{raw-initrd}.
+@var{mapped-devices}, @var{guile}, @var{qemu-networking?} and
+@var{volatile-root?} also behave as in @code{raw-initrd}.
 
 When @var{virtio?} is true, load additional modules so that the
 initrd can be used as a QEMU guest with para-virtualized I/O drivers.
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 330438bce..301e6cffa 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -154,17 +154,18 @@ MODULES and taken from LINUX."
                       (linux-modules '())
                       (mapped-devices '())
                       (helper-packages '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (on-error 'debug))
-  "Return a monadic derivation that builds a raw initrd, with kernel
-modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
-mounted by the initrd, possibly in addition to the root file system specified
-on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
-modules to be loaded at boot time. MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
-HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
-e2fsck/static or other packages needed by the initrd to check root partition.
+  "Return a monadic derivation that builds a raw initrd, with kernel modules
+taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be mounted by the
+initrd, possibly in addition to the root file system specified on the kernel
+command line via '--root'.  LINUX-MODULES is a list of kernel modules to be
+loaded at boot time.  MAPPED-DEVICES is a list of device mappings to realize
+before FILE-SYSTEMS are mounted.  HELPER-PACKAGES is a list of packages to be
+copied in the initrd. It may include e2fsck/static or other packages needed by
+the initrd to check root partition.  GUILE is the Guile to use in the initrd.
 
 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 parameters.
@@ -223,7 +224,8 @@ upon error."
                       #:qemu-guest-networking? #$qemu-networking?
                       #:volatile-root? '#$volatile-root?
                       #:on-error '#$on-error)))
-   #:name "raw-initrd"))
+   #:name "raw-initrd"
+   #:guile guile))
 
 (define* (file-system-packages file-systems #:key (volatile-root? #f))
   "Return the list of statically-linked, stripped packages to check
@@ -246,6 +248,7 @@ FILE-SYSTEMS."
                       #:key
                       (linux linux-libre)
                       (mapped-devices '())
+                      (guile %guile-static-stripped)
                       qemu-networking?
                       volatile-root?
                       (virtio? #t)
@@ -255,7 +258,8 @@ FILE-SYSTEMS."
 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 mounted by the initrd, possibly in addition to the root file system specified
 on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
-mappings to realize before FILE-SYSTEMS are mounted.
+mappings to realize before FILE-SYSTEMS are mounted.  GUILE is the Guile to
+use in the initrd.
 
 QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
 
@@ -325,6 +329,7 @@ loaded at boot time in the order in which they appear."
               #:helper-packages helper-packages
               #:qemu-networking? qemu-networking?
               #:volatile-root? volatile-root?
-              #:on-error on-error))
+              #:on-error on-error
+              #:guile guile))
 
 ;;; linux-initrd.scm ends here
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Chris Marusich]

[-- Attachment #1: Type: text/plain, Size: 1990 bytes --]

ludo@gnu.org (Ludovic Courtès) writes:

> Chris Marusich <cmmarusich@gmail.com> skribis:
>
>> +TMPDIR is the name of the temporary working directory to use.  This can be
>> +useful if you need to use a specific temporary directory, for example because
>> +the default temporary directory lies on a file system with insufficient
>> +space."
>
> Usually this code is used in a derivation, where it doesn’t really
> matter which directory is used, no?

I added this because I thought I needed it in order to implement "guix
system docker-image".  I build the Docker image in a VM, and the VM's
file system is too small to hold all the transient files that are
created by build-docker-image (in guix/docker.scm).  Without this
change, the derivation fails due to lack of space within the VM.  I work
around this limitation by using the /xchg directory as the temporary
directory in the VM, which does have enough space to hold all the
transient files.

However, thinking about this now, maybe the right thing to do is to
adjust the heuristics for guessing the right disk size in
expression->derivation-in-linux-vm (in gnu/system/vm.scm).  Or maybe I
can just provide my own estimate via the #:disk-image-size argument.
Maybe if I adjust that, I will be able to build the Docker image without
specifying a custom temporary directory.  That would be nice; I'll try
to do it and let you know how it goes.

Another option here would be to build the Docker image without using a
VM in the first place.  Perhaps we can use namespaces, but I haven't
tried that yet, since the VM approach worked.  I tried without a VM
first, and I quickly found that I couldn't do many things in a normal
derivation that I needed to do in order to build the image (e.g., create
device files).  I don't know if I can do all those necessary things
without using a VM.  But I think we can iterate on that after this patch
series gets committed.

What do you think?

-- 
Chris

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#30572] [PATCH 3/7] system: Allow customization of the initrd's Guile.

[Ludovic Courtès]

Chris Marusich <cmmarusich@gmail.com> skribis:

> ludo@gnu.org (Ludovic Courtès) writes:
>
>> Chris Marusich <cmmarusich@gmail.com> skribis:
>>
>>>  @deffn {Monadic Procedure} base-initrd @var{file-systems} @
>>> -       [#:mapped-devices '()] [#:qemu-networking? #f] [#:volatile-root? #f]@
>>> +       [#:linux linux-libre]
>>> +       [#:mapped-devices '()] [#:guile %guile-static-stripped]
>>> +       [#:qemu-networking? #f] [#:volatile-root? #f]@
>>
>> Nitpick: you need an @ at the end of intermediate lines.  :-)
>
> Thank you; I appreciate nit-picking, since these are the kinds of things
> that are easy to overlook!  I've added the @ symbols (see attached).
> However, are they really necessary?
>
> According to (texinfo) Multiple Spaces, inserting an @ followed by a
> newline inserts a single space into the output.  That's what we're doing
> here, right?  But even when I omit the @ symbols at the end of the
> lines, the TexInfo manual builds without error, and the procedure
> definition appears to render just fine in the stand-alone Info reader.
> Unless the intent here really is to insert just one extra space between
> some, but not all, of the arguments, I think we can probably omit all of
> these @ symbols.  WDYT?

It surely builds without error, but I think Texinfo considers the lines
that follow the @deffn line as the body of @deffn and not as the
continuation of the @deffn line.

Thanks,
Ludo’.

[bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.

[Ludovic Courtès]

Hello,

Chris Marusich <cmmarusich@gmail.com> skribis:

> Another option here would be to build the Docker image without using a
> VM in the first place.  Perhaps we can use namespaces, but I haven't
> tried that yet, since the VM approach worked.  I tried without a VM
> first, and I quickly found that I couldn't do many things in a normal
> derivation that I needed to do in order to build the image (e.g., create
> device files).  I don't know if I can do all those necessary things
> without using a VM.

We need a VM so that we can be root and create and mount file systems,
right?

That’s a good reason to use a VM.  :-)

What about making /tmp in the VM a 9p mount of /tmp outside the VM?
That way this would be transparent, and no need to fiddle with the VM
disk sizes.

WDYT?

Thanks,
Ludo’.

[bug#30572] [PATCH 1/7] tests: Add tests for "guix pack".

[Ludovic Courtès]

Howdy,

Chris Marusich <cmmarusich@gmail.com> skribis:

> ludo@gnu.org (Ludovic Courtès) writes:
>
>>> +# Use --dry-run because it takes too long to actually build everything.
>>> +GUIX_BUILD_OPTIONS="--no-substitutes --dry-run"
>>> +export GUIX_BUILD_OPTIONS
>>> +
>>> +# Build a tarball.
>>> +guix pack coreutils
>>
>> It would be ideal if we could actually build something, but built
>> something cheap.
>>
>> The way we do that in those tests is by:
>>
>>   1. Using the ‘guile-bootstrap’ package as an example, under the
>>      assumption that it’s already available, does not require
>>      networking, and is built in one or two seconds.
>>
>>   2. Using ‘--bootstrap’ or a similar option so that the derivations use
>>      ‘guile-bootstrap’ instead of ‘guile-final’, for the same reason.
>>
>> See for instance tests/guix-package.sh.
>>
>> Would you be willing to try something along these lines?
>
> That's a good idea!  I tried it (see attached patch).  Unfortunately,
> even after adding a --bootstrap option, "guix pack" tries to build many
> things, so tests/guix-pack.sh takes hours to run the first time you try
> it (it ran for 2 hours on my laptop and then failed because gcc failed
> to build for unrelated reasons):

[...]

> It's quicker after the first time, but it's a hefty one-time cost.
>
> I think so many things need to be built because "guix pack" creates the
> pack using a gexp that uses packages.  For example, instead of executing
> "tar" by looking it up in the current environment (e.g. via system*), it
> builds the "tar" package and executes the resulting "tar" program in the
> gexp that creates the pack.  Therefore, even though we do use
> guile-bootstrap to run the gexp, Guix still need to build tar and all of
> its dependencies, so the test takes hours to run.  Can we do better?

Ah indeed, I hadn’t thought about tar.

We could arrange for ‘--bootstrap’ to use:

  (search-bootstrap-binary "tar")

instead of the ‘tar’ package.  We could do the same for ‘xz’.  (You’d
need a ‘trivial-build-system’ package that copies these two binaries in
$out/bin.)

How does that sound?

> Maybe we could move tests like these to a "long-running" test target
> (e.g., "make check-long-running").  I think this could work, but I would
> much rather just write tests that run quickly.

We could do that but let’s see if we can avoid it for now.  :-)

> Maybe we could rewrite "guix pack" so that it uses system* to run tar.

I’d rather not hinder reproducibility “just” for a test.

> Finally, maybe we could stick with running the tests in "dry-run" mode.
> I'm in favor of this idea, but obviously I'm a little biased.  :-)

Well, that would work too, indeed.  :-)

> From 72e672e795fe8f4d67f7e1805ba8b88c874f3fb1 Mon Sep 17 00:00:00 2001
> From: Chris Marusich <cmmarusich@gmail.com>
> Date: Tue, 20 Feb 2018 02:17:54 +0100
> Subject: [PATCH 1/7] tests: Add tests for "guix pack".
>
> * guix/scripts/pack.scm (%options): Add the --bootstrap option.
>   (show-help): Document it.
>   (guix-pack): Honor it.
> * doc/guix.texi (Invoking guix pack): Document the new --bootstrap
>   option.
> * tests/guix-pack.sh: New file.
> * Makefile.am (SH_TESTS): Add guix-pack.sh.
> * gnu/packages/package-management.scm (guix) <inputs>: Add util-linux.

[...]

> +# Build a tarball with a symlink.
> +the_pack="$(guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap)"

In general we use backticks instead of $(…) to stick to POSIX shells.

> +# Build a tarball pack of cross-compiled software.
> +guix pack --bootstrap --target=arm-unknown-linux-gnueabihf guile-bootstrap

This one is a little bit too costly (plus it wouldn’t work because
guile-bootstrap is not actually cross-compilable), so I’d suggest add
‘--dry-run’ and removing ‘-bootstrap’.  :-)

HTH!

Ludo’.