vm: 'system-docker-image' provides an entry point.

This simplifies use of images created with 'guix system docker-image'.

* gnu/system/vm.scm (system-docker-image)[boot-program]: New variable.
[os]: Add it to the GC roots.
[build]: Pass #:entry-point to 'build-docker-image'.
* gnu/tests/docker.scm (run-docker-system-test): New procedure.
(%test-docker-system): New variable.
* doc/guix.texi (Invoking guix system): Remove GUIX_NEW_SYSTEM hack and
'--entrypoint' from the example.  Mention 'docker create', 'docker
start', and 'docker exec'.

2 files changed, 133 insertions, 3 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 2eeb700793..aa37896498 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -482,7 +482,7 @@ system."
 
 (define* (system-docker-image os
                               #:key
-                              (name "guixsd-docker-image")
+                              (name "guix-docker-image")
                               (register-closures? (has-guix-service-type? os)))
   "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 true,
@@ -495,7 +495,19 @@ system."
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
-  (let ((os    (containerized-operating-system os '()))
+  (define boot-program
+    ;; Program that runs the boot script of OS, which in turn starts shepherd.
+    (program-file "boot-program"
+                  #~(let ((system (cadr (command-line))))
+                      (setenv "GUIX_NEW_SYSTEM" system)
+                      (execl #$(file-append guile-2.2 "/bin/guile")
+                             "guile" "--no-auto-compile"
+                             (string-append system "/boot")))))
+
+
+  (let ((os    (operating-system-with-gc-roots
+                (containerized-operating-system os '())
+                (list boot-program)))
         (name  (string-append name ".tar.gz"))
         (graph "system-graph"))
     (define build
@@ -546,9 +558,11 @@ system."
                                  (string-append "/xchg/" #$graph)
                                read-reference-graph)))
                  #$os
+                 #:entry-point '(#$boot-program #$os)
                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
                  #:creation-time (make-time time-utc 0 1)
                  #:transformations `((,root-directory -> ""))))))))
+
     (expression->derivation-in-linux-vm
      name build
      #:make-disk-image? #f
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 25e172efae..3cd3a27884 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #:use-module (gnu services desktop)
   #:use-module (gnu packages bootstrap) ; %bootstrap-guile
   #:use-module (gnu packages docker)
+  #:use-module (gnu packages guile)
   #:use-module (guix gexp)
   #:use-module (guix grafts)
   #:use-module (guix monads)
@@ -38,7 +40,8 @@
   #:use-module (guix tests)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (%test-docker))
+  #:export (%test-docker
+            %test-docker-system))
 
 (define %docker-os
   (simple-operating-system
@@ -166,3 +169,116 @@ standard output device and then enters a new line.")
    (name "docker")
    (description "Test Docker container of Guix.")
    (value (build-tarball&run-docker-test))))
+
+
+(define (run-docker-system-test tarball)
+  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
+inside %DOCKER-OS."
+  (define os
+    (marionette-operating-system
+     %docker-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     ;; FIXME: Because we're using the volatile-root setup where the root file
+     ;; system is a tmpfs overlaid over a small root file system, 'docker
+     ;; load' must be able to store the whole image into memory, hence the
+     ;; huge memory requirements.  We should avoid the volatile-root setup
+     ;; instead.
+     (memory-size 3000)
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette)
+                       (guix build utils))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "docker")
+
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'dockerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "load system image and run it"
+            (marionette-eval
+             `(begin
+                (define (slurp command . args)
+                  ;; Return the output from COMMAND.
+                  (let* ((port (apply open-pipe* OPEN_READ command args))
+                         (output (read-line port))
+                         (status (close-pipe port)))
+                    output))
+
+                (define (docker-cli command . args)
+                  ;; Run the given Docker COMMAND.
+                  (apply invoke #$(file-append docker-cli "/bin/docker")
+                         command args))
+
+                (define (wait-for-container-file container file)
+                  ;; Wait for FILE to show up in CONTAINER.
+                  (docker-cli "exec" container
+                              #$(file-append guile-2.2 "/bin/guile")
+                              "-c"
+                              (object->string
+                               `(let loop ((n 15))
+                                  (when (zero? n)
+                                    (error "file didn't show up" ,file))
+                                  (unless (file-exists? ,file)
+                                    (sleep 1)
+                                    (loop (- n 1)))))))
+
+                (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
+                                    "load" "-i" #$tarball))
+                       (repository&tag (string-drop line
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (container (slurp
+                                   #$(file-append docker-cli "/bin/docker")
+                                   "create" repository&tag)))
+                  (docker-cli "start" container)
+
+                  ;; Wait for shepherd to be ready.
+                  (wait-for-container-file container
+                                           "/var/run/shepherd/socket")
+
+                  (docker-cli "exec" container
+                              "/run/current-system/profile/bin/herd"
+                              "status")
+                  (slurp #$(file-append docker-cli "/bin/docker")
+                         "exec" container
+                         "/run/current-system/profile/bin/herd"
+                         "status" "guix-daemon")))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "docker-system-test" test))
+
+(define %test-docker-system
+  (system-test
+   (name "docker-system")
+   (description "Run a system image as produced by @command{guix system
+docker-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (system-docker-image (simple-operating-system))
+                 run-docker-system-test)))))