diff --git a/doc/guix.texi b/doc/guix.texi
index 41ea3c314d8d489808c8d09b22a143e99a9f3639..ae9ad0739e9f7ae91a6eccfd36de3de37bdc80a3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24500,20 +24500,26 @@ system configuration file. You can then load the image and launch a
Docker container using commands like the following:
@example
-image_id="$(docker load < guix-system-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
+image_id="`docker load < guix-system-docker-image.tar.gz`"
+container_id="`docker create $image_id`"
+docker start $container_id
@end example
This command starts a new Docker container from the specified image. It
will boot the Guix 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
+configuration. You can get an interactive shell running in the container
+using @command{docker exec}:
+
+@example
+docker exec -ti $container_id /run/current-system/profile/bin/bash --login
+@end example
+
+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}.
+@code{docker create}.
@item container
Return a script to run the operating system declared in @var{file}
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 2eeb7007935b01f40beca98ffa9c4993958d1204..aa3789649872703121589eb2d6dbcba845a7c165 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -482,7 +482,7 @@ (define schema
(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 @@ (define schema
(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 @@ (define build
(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 25e172efae376df8384227f28c006ffc3987e748..3cd3a2788403509f255650ed24947251b8b66117 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 @@ (define-module (gnu tests docker)
#: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 @@ (define-module (gnu tests docker)
#: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 @@ (define %test-docker
(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)))))