From 5ea69d9a563fa1e2890c94fe9574c7e16f778f3b Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 3 Apr 2017 23:49:22 -0700
Subject: [PATCH] system: Support the --root option in 'guix system'.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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 <ludo@gnu.org>
---
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 c29af46ff12..d413ea4a501 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}).
+@item --root=@var{file}
+@itemx -r @var{file}
+Make @var{file} a symlink to the result, and register it as a garbage
+collector root.
+
@item --on-error=@var{strategy}
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 144a7fd377c..b0a794bf8ed 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 <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -593,7 +593,8 @@ (define* (perform-action action os
#: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 @@ (define* (perform-action action os
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 @@ (define println
#: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."
@@ -740,6 +749,10 @@ (define (show-help)
--no-grub for 'init', do not install GRUB"))
(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 (_ "
@@ -797,6 +810,9 @@ (define %options
(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 @@ (define (process-action action args opts)
(_ #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)
--
GitLab