From e96c877459555f4cf868fb5fe4579183f6a773d5 Mon Sep 17 00:00:00 2001
From: Chris Marusich
Date: Mon, 3 Apr 2017 23:49:22 -0700
Subject: [PATCH 2/2] system: Support the --root option in 'guix system'.
Fixes .
* guix/scripts/system.scm (perform-action): Add parameters 'store' and
'gc-root'. Update docstring.
(perform-action) [gc-root]: Add an indirect GC root using store.
(%options): Add 'root'.
(process-action): Pass 'store' and 'root' to perform-action.
---
guix/scripts/system.scm | 34 +++++++++++++++++++++++-----------
1 file changed, 23 insertions(+), 11 deletions(-)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 144a7fd37..54a9e1d37 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -589,19 +589,24 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(warning (_ "Consider running 'guix pull' before 'reconfigure'.~%"))
(warning (_ "Failing to do that may downgrade your system!~%"))))
-(define* (perform-action action os
+(define* (perform-action store action os
#:key grub? dry-run? derivations-only?
use-substitutes? device target
image-size full-boot?
- (mappings '()))
- "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'
-actions. FULL-BOOT? is used for the 'vm' action; it determines whether to
-boot directly to the kernel or to the bootloader.
+ (mappings '())
+ (gc-root #f))
+ "Perform ACTION for OS using STORE, which is an open connection to the
+store. 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' 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~%" <>))
@@ -666,7 +671,10 @@ building anything."
#:device device))
(else
;; All we had to do was to build SYS.
- (return (derivation->output-path sys))))))))
+ (return (let ((output-path (derivation->output-path sys)))
+ (if gc-root
+ (register-root store (list output-path) gc-root)
+ output-path)))))))))
(define (export-extension-graph os port)
"Export the service extension graph of OS to PORT."
@@ -797,6 +805,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
@@ -850,7 +861,7 @@ resulting from command-line parsing."
((shepherd-graph)
(export-shepherd-graph os (current-output-port)))
(else
- (perform-action action os
+ (perform-action store action os
#:dry-run? dry?
#:derivations-only? (assoc-ref opts
'derivations-only?)
@@ -863,7 +874,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)
--
2.12.0