From f943c317fb714075b455d4a30f631c8cb45732b4 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 20 Dec 2016 19:06:22 +0100
Subject: environment: Add '--root' option.

* guix/scripts/environment.scm (show-help, %options): Add --root.
(register-gc-root): New procedure.
(guix-environment): Call 'register-gc-root' when OPTS has a 'gc-root'
option.
* doc/guix.texi (Invoking guix environment): Document it.
* tests/guix-environment.sh: Add tests.
---
 doc/guix.texi                | 15 +++++++++++++++
 guix/scripts/environment.scm | 34 ++++++++++++++++++++++++++++++++--
 tests/guix-environment.sh    | 17 ++++++++++++++++-
 3 files changed, 63 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 512b3ae9ce..69129d5835 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5997,6 +5997,21 @@ The @code{--container} option requires Linux-libre 3.19 or newer.
 The available options are summarized below.
 
 @table @code
+@item --root=@var{file}
+@itemx -r @var{file}
+@cindex persistent environment
+@cindex garbage collector root, for environments
+Make @var{file} a symlink to the profile for this environment, and
+register it as a garbage collector root.
+
+This is useful if you want to protect your environment from garbage
+collection, to make it ``persistent''.
+
+When this option is omitted, the environment is protected from garbage
+collection only for the duration of the @command{guix environment}
+session.  This means that next time you recreate the same environment,
+you could have to rebuild or re-download packages.
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Create an environment for the package or list of packages that
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 7201d98fea..1d3be6a84f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -155,6 +155,9 @@ COMMAND or an interactive shell in that environment.\n"))
   (display (_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (display (_ "
+  -r, --root=FILE        make FILE a symlink to the result, and register it
+                         as a garbage collector root"))
+  (display (_ "
   -C, --container        run command within an isolated container"))
   (display (_ "
   -N, --network          allow containers to access the network"))
@@ -247,6 +250,9 @@ COMMAND or an interactive shell in that environment.\n"))
                    (alist-cons 'file-system-mapping
                                (specification->file-system-mapping arg #f)
                                result)))
+         (option '(#\r "root") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'gc-root arg result)))
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
@@ -523,7 +529,26 @@ message if any test fails."
     (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n"))
     (leave (_ "is your kernel version < 3.19?\n"))))
 
-;; Entry point.
+(define (register-gc-root target root)
+  "Make ROOT an indirect root to TARGET.  This is procedure is idempotent."
+  (let* ((root (string-append (canonicalize-path (dirname root))
+                              "/" root)))
+    (catch 'system-error
+      (lambda ()
+        (symlink target root)
+        ((store-lift add-indirect-root) root))
+      (lambda args
+        (if (and (= EEXIST (system-error-errno args))
+                 (equal? (false-if-exception (readlink root)) target))
+            (with-monad %store-monad
+              (return #t))
+            (apply throw args))))))
+
+
+;;;
+;;; Entry point.
+;;;
+
 (define (guix-environment . args)
   (with-error-handling
     (let* ((opts       (parse-args args))
@@ -579,7 +604,9 @@ message if any test fails."
                                                                system))
                                  (prof-drv   (inputs->profile-derivation
                                               inputs system bootstrap?))
-                                 (profile -> (derivation->output-path prof-drv)))
+                                 (profile -> (derivation->output-path prof-drv))
+                                 (gc-root -> (assoc-ref opts 'gc-root)))
+
               ;; First build the inputs.  This is necessary even for
               ;; --search-paths.  Additionally, we might need to build bash for
               ;; a container.
@@ -588,6 +615,9 @@ message if any test fails."
                                        (list prof-drv bash)
                                        (list prof-drv))
                                    opts)
+                (mwhen gc-root
+                  (register-gc-root profile gc-root))
+
                 (cond
                  ((assoc-ref opts 'dry-run?)
                   (return #t))
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index 68343520b0..2b3bbfe036 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -25,7 +25,8 @@ set -e
 guix environment --version
 
 tmpdir="t-guix-environment-$$"
-trap 'rm -r "$tmpdir"' EXIT
+gcroot="t-guix-environment-gc-root-$$"
+trap 'rm -r "$tmpdir"; rm -f "$gcroot"' EXIT
 
 mkdir "$tmpdir"
 
@@ -61,6 +62,20 @@ fi
 guix environment --bootstrap --ad-hoc guile-bootstrap --pure \
      -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"'
 
+# Make sure '-r' works as expected.
+rm -f "$gcroot"
+expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \
+             -- "$SHELL" -c 'echo $GUIX_ENVIRONMENT'`"
+guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \
+     -- guile -c 1
+test `readlink "$gcroot"` = "$expected"
+
+# Make sure '-r' is idempotent.
+guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \
+     -- guile -c 1
+test `readlink "$gcroot"` = "$expected"
+
+
 case "`uname -m`" in
     x86_64)
 	# On x86_64, we should be able to create a 32-bit environment.
-- 
cgit 1.4.1