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

[Chris Marusich <cmmarusich@gmail.com>]

* 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                         |  36 +++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 113 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  12 ++--
 4 files changed, 200 insertions(+), 8 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 792539a12..8d38c3d4a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20361,12 +20361,18 @@ containing at least the kernel, initrd, and bootloader data files must
 be created.  The @code{--image-size} option can be used to specify the
 size of the image.
 
+@cindex System images, creation in various formats
+@cindex Creating system images in various formats
 @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}.
@@ -20384,6 +20390,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 d239fa56a..dd3641151 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,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)
@@ -30,6 +31,7 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix base32)
@@ -39,7 +41,9 @@
   #: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)
@@ -76,6 +80,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -376,6 +381,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 the Shepherd), then you
+should set REGISTER-CLOSURES? to #f."
+  (define not-config?
+    (match-lambda
+      (('guix 'config) #f)
+      (('guix rest ...) #t)
+      (('gnu rest ...) #t)
+      (rest #f)))
+
+  (define config
+    ;; (guix config) module for consumption by (guix gcrypt).
+    (scheme-file "gcrypt-config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libgcrypt))
+
+                     ;; 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"))
+                      (graph -> "system-graph"))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (guix build utils)
+                                                          (gnu build vm))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((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 (guix docker)
+                         (guix build utils)
+                         (gnu build vm)
+                         (srfi srfi-19)
+                         (guix build store-copy))
+
+            (let* ((inputs '#$(append (list tar)
+                                      (if register-closures?
+                                          (list guix)
+                                          '())))
+                   ;; This initializer requires elevated privileges that are
+                   ;; not normally available in the build environment (e.g.,
+                   ;; it needs to create device nodes).  In order to obtain
+                   ;; such privileges, we run it as root in a VM.
+                   (initialize (root-partition-initializer
+                                #:closures '(#$graph)
+                                #: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))
+                   ;; Even as root in a VM, the initializer would fail due to
+                   ;; lack of privileges if we use a root-directory that is on
+                   ;; a file system that is shared with the host (e.g., /tmp).
+                   (root-directory "/guixsd-system-root"))
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir root-directory)
+              (initialize root-directory)
+              (build-docker-image
+               (string-append "/xchg/" #$name) ;; The output file.
+               (cons* root-directory
+                      (call-with-input-file (string-append "/xchg/" #$graph)
+                        read-reference-graph))
+               #$os-drv
+               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+               #:creation-time (make-time time-utc 0 1)
+               #:transformations `((,root-directory -> "")))))))
+    (expression->derivation-in-linux-vm
+     name
+     ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
+     ;; needs to be run by a Guile that can dlopen libgcrypt.  The following
+     ;; hack works around that problem by putting the "build" gexp into an
+     ;; executable script (created by program-file) which, when executed, will
+     ;; run using a Guile that supports dlopen.  That way, the VM's initrd
+     ;; Guile can just execute it via invoke, without using dlopen.  See:
+     ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+     (with-imported-modules `((guix build utils))
+       #~(begin
+           (use-modules (guix build utils))
+           ;; If we use execl instead of invoke here, the VM will crash with a
+           ;; kernel panic.
+           (invoke #$(program-file "build-docker-image" build))))
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,graph ,os-drv)))))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index acfccce96..09f99b300 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -701,7 +701,9 @@ checking this by themselves in their 'check' procedure."
                                  ("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."
@@ -899,6 +901,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_ "\
@@ -1130,7 +1134,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))))))
 
@@ -1159,7 +1163,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