mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 05:57:04 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Chris Marusich 2017-04-03 23:49:22 -07:00 committed by Ludovic Courtès
parent a09b45da6f
commit 5ea69d9a56
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 29 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
doc/guix.texi
View file

@ -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:

31
guix/scripts/system.scm
View file

@ -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)