bug#26271: 'guix system' does not support common build option '--root'

[Chris Marusich <cmmarusich@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 3041 bytes --]

ludo@gnu.org (Ludovic Courtès) writes:

>> From ccf03e4bb5d5c2d3a47efdf64e36a7d903bfb2c5 Mon Sep 17 00:00:00 2001
>> From: Chris Marusich <cmmarusich@gmail.com>
>> Date: Mon, 3 Apr 2017 23:47:22 -0700
>> Subject: [PATCH 1/2] build: Export register-root procedure.
>>
>> * guix/scripts/build.scm: Export register-root procedure.
>
> Applied.

Thank you!

>> From e96c877459555f4cf868fb5fe4579183f6a773d5 Mon Sep 17 00:00:00 2001
>> From: Chris Marusich <cmmarusich@gmail.com>
>> Date: Mon, 3 Apr 2017 23:49:22 -0700
>> Subject: [PATCH 2/2] system: Support the --root option in 'guix system'.
>>
>> Fixes <https://bugs.gnu.org/26271>.
>>
>> * 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.
>
> [...]
>
>> -(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 '()))
>
>
> [...]
>
>>               ;; 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)))))))))
>
> ‘perform-action’ is a monadic procedure; IOW, the ‘store’ parameter is
> already threaded into it.  Thus, instead of adding an explicit ‘store’
> parameter, which must “lift” ‘register-root’ in the store monad:
>
>   (define register-root*
>     (store-lift register-root))
>
> and then use it like a normal monadic procedure:
>
>   (let ((output (derivation->output-path sys)))
>     (mbegin %store-monad
>       (mwhen gc-root
>         (register-root* (list output) gc-root))
>       (return output)))
>
> Could you change this patch along these lines?

Thank you for reminding me that we can do it this way!  I've updated the
patch and verified that it still works.

> Also please make sure to mention ‘--root’ in ‘show-help’ and in
> guix.texi.

In the attached patch series, I've mentioned '--root' in 'show-help'.
However, since there is already a link in the '(guix) Invoking guix
system)' section to the section which describes the common build options
((guix) Common Build Options), I decided not to duplicate the
documentation for '--root' in that section.

If you still think we should mention '--root' in '(guix) Invoking guix
system)', let me know and I will submit another small patch to add it.

Now we can generate system images without fear of the reaper!  The
garbage reaper, that is :-)

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-build-Add-and-export-procedure-register-root.patch --]
[-- Type: text/x-patch, Size: 1232 bytes --]

From 8b768570b26d9a44ea140b0cd29383d32d37a0df Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Tue, 4 Apr 2017 20:24:54 -0700
Subject: [PATCH 1/2] build: Add and export procedure 'register-root*'.

* guix/scripts/build.scm (register-root*): Add and export it.
---
 guix/scripts/build.scm | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ba47b1232..6bb1f72eb 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -52,7 +52,8 @@
             show-transformation-options-help
 
             guix-build
-            register-root))
+            register-root
+            register-root*))
 
 (define %default-log-urls
   ;; Default base URLs for build logs.
@@ -123,6 +124,9 @@ found.  Return #f if no build log was found."
         (leave (_ "failed to create GC root `~a': ~a~%")
                root (strerror (system-error-errno args)))))))
 
+(define register-root*
+  (store-lift register-root))
+
 (define (package-with-source store p uri)
   "Return a package based on P but with its source taken from URI.  Extract
 the new package's version number from URI."
-- 
2.12.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: 0002-system-Support-the-root-option-in-guix-system.patch --]
[-- Type: text/x-patch, Size: 4082 bytes --]

From 430fdb321f3401d5a498f002291ae520d47f1dcf Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 3 Apr 2017 23:49:22 -0700
Subject: [PATCH 2/2] 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.
---
 guix/scripts/system.scm | 25 ++++++++++++++++++++-----
 1 file changed, 20 insertions(+), 5 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 144a7fd37..d867465dd 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -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,11 @@ 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.
+             (mwhen gc-root
+               (register-root* (list (derivation->output-path sys))
+                               gc-root))))))))
 
 (define (export-extension-graph os port)
   "Export the service extension graph of OS to PORT."
@@ -741,6 +748,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 +808,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 +877,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


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]