From 247649d42e60b718f3f46b2bcf72d19bf799d503 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 12 May 2019 12:21:48 +0200
Subject: 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'.
---
 gnu/system/vm.scm | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

(limited to 'gnu/system/vm.scm')

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
-- 
cgit v1.2.3