[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                         |  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