02/02: system: Support the --root option in 'guix system'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 5ea69d9a563fa1e2890c94fe9574c7e16f778f3b
Author: Chris Marusich <address@hidden>
Date:   Mon Apr 3 23:49:22 2017 -0700

    system: Support the --root option in 'guix system'.
    
    Fixes <https://bugs.gnu.org/26271>.
    
    * guix/scripts/system.scm (perform-action): Add #:gc-root parameter and
    honor it.
    (show-help): Document the --root option.
    (%options): Add 'root'.
    (process-action): Pass 'root' option to perform-action as #:gc-root.
    * doc/guix.texi (Invoking guix system): Document '--root'.
    
    Signed-off-by: Ludovic Courtès <address@hidden>
---
 doc/guix.texi           |  5 +++++
 guix/scripts/system.scm | 31 ++++++++++++++++++++++++-------
 2 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c29af46..d413ea4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -15238,6 +15238,11 @@ of the given @var{size}.  @var{size} may be a number 
of bytes, or it may
 include a unit as a suffix (@pxref{Block size, size specifications,,
 coreutils, GNU Coreutils}).
 
address@hidden address@hidden
address@hidden -r @var{file}
+Make @var{file} a symlink to the result, and register it as a garbage
+collector root.
+
 @item address@hidden
 Apply @var{strategy} when an error occurs when reading @var{file}.
 @var{strategy} may be one of the following:
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 144a7fd..b0a794b 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 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
-;;; Copyright © 2016 Chris Marusich <address@hidden>
+;;; Copyright © 2016, 2017 Chris Marusich <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -593,7 +593,8 @@ PATTERN, a string.  When PATTERN is #f, display all the 
system generations."
                          #:key grub? dry-run? derivations-only?
                          use-substitutes? device target
                          image-size full-boot?
-                         (mappings '()))
+                         (mappings '())
+                         (gc-root #f))
   "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
 the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
 is the size of the image to be built, for the 'vm-image' and 'disk-image'
@@ -601,7 +602,10 @@ actions.  FULL-BOOT? is used for the 'vm' action; it 
determines whether to
 boot directly to the kernel or to the bootloader.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
-building anything."
+building anything.
+
+When GC-ROOT is a path, also make that path an indirect root of the build
+output when building a system derivation, such as a disk image."
   (define println
     (cut format #t "~a~%" <>))
 
@@ -665,8 +669,13 @@ building anything."
                       #:grub.cfg (derivation->output-path grub.cfg)
                       #:device device))
             (else
-             ;; All we had to do was to build SYS.
-             (return (derivation->output-path sys))))))))
+             ;; All we had to do was to build SYS and maybe register an
+             ;; indirect GC root.
+             (let ((output (derivation->output-path sys)))
+               (mbegin %store-monad
+                 (mwhen gc-root
+                   (register-root* (list output) gc-root))
+                 (return output)))))))))
 
 (define (export-extension-graph os port)
   "Export the service extension graph of OS to PORT."
@@ -741,6 +750,10 @@ Some ACTIONS support additional ARGS.\n"))
   (display (_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
   (display (_ "
+  -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'container',
+                         and 'build', make FILE a symlink to the result, and
+                         register it as a garbage collector root"))
+  (display (_ "
       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
   (display (_ "
       --full-boot        for 'vm', make a full boot sequence"))
@@ -797,6 +810,9 @@ Some ACTIONS support additional ARGS.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '(#\r "root") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'gc-root arg result)))
          %standard-build-options))
 
 (define %default-options
@@ -863,7 +879,8 @@ resulting from command-line parsing."
                                                       (_ #f))
                                                     opts)
                              #:grub? grub?
-                             #:target target #:device device))))
+                             #:target target #:device device
+                             #:gc-root (assoc-ref opts 'gc-root)))))
         #:system system))))
 
 (define (process-command command args opts)