From 34811f02bf176c307ebe329aaefab8ed616a10df Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 30 Oct 2012 00:20:53 +0100
Subject: [PATCH] guix-build: Add `--root'.

* guix/store.scm (add-indirect-root): New operation.
* guix-build.in (show-help): Document `--root'.
  (%options): Add `--root'.
  (guix-build)[register-root]: New procedure.  Call it when `--root' is
  passed.
---
 guix-build.in  | 46 ++++++++++++++++++++++++++++++++++++++++++++--
 guix/store.scm |  8 ++++++++
 2 files changed, 52 insertions(+), 2 deletions(-)

diff --git a/guix-build.in b/guix-build.in
index bd32ce951e..7089a74731 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -101,6 +101,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
       --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
   -c, --cores=N          allow the use of up to N CPU cores for the build"))
+  (display (_ "
+  -r, --root=FILE        make FILE a symlink to the result, and register it
+                         as a garbage collector root"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -151,7 +154,10 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
         (option '("no-substitutes") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'substitutes? #f
-                              (alist-delete 'substitutes? result))))))
+                              (alist-delete 'substitutes? result))))
+        (option '(#\r "root") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'gc-root arg result)))))
 
 
 ;;;
@@ -168,6 +174,33 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
                  (alist-cons 'argument arg result))
                %default-options))
 
+  (define (register-root drv root)
+    ;; Register ROOT as an indirect GC root for DRV's outputs.
+    (let* ((root     (string-append (canonicalize-path (dirname root))
+                                    "/" root))
+           (drv*     (call-with-input-file drv read-derivation))
+           (outputs  (derivation-outputs drv*))
+           (outputs* (map (compose derivation-output-path cdr) outputs)))
+     (catch 'system-error
+       (lambda ()
+         (match outputs*
+           ((output)
+            (symlink output root)
+            (add-indirect-root %store root))
+           ((outputs ...)
+            (fold (lambda (output count)
+                    (let ((root (string-append root "-" (number->string count))))
+                      (symlink output root)
+                      (add-indirect-root %store root))
+                    (+ 1 count))
+                  0
+                  outputs))))
+       (lambda args
+         (format (current-error-port)
+                 (_ "failed to create GC root `~a': ~a~%")
+                 root (strerror (system-error-errno args)))
+         (exit 1)))))
+
   (setlocale LC_ALL "")
   (textdomain "guix")
   (setvbuf (current-output-port) _IOLBF)
@@ -244,7 +277,16 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
                                                 (derivation-path->output-path
                                                  d out-name)))
                                               (derivation-outputs drv)))))
-                             drv)))))))
+                             drv)
+                   (let ((roots (filter-map (match-lambda
+                                             (('gc-root . root)
+                                              root)
+                                             (_ #f))
+                                            opts)))
+                     (when roots
+                       (for-each (cut register-root <> <>)
+                                 drv roots)
+                       #t))))))))
 
 ;; Local Variables:
 ;; eval: (put 'guard 'scheme-indent-function 1)
diff --git a/guix/store.scm b/guix/store.scm
index 34421a11df..5ac98d80bb 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -49,6 +49,7 @@
             add-text-to-store
             add-to-store
             build-derivations
+            add-indirect-root
 
             current-build-output-port
 
@@ -419,6 +420,13 @@ again until #t is returned or an error is raised."
 Return #t on success."
   boolean)
 
+(define-operation (add-indirect-root (string file-name))
+  "Make FILE-NAME an indirect root for the garbage collector; FILE-NAME
+can be anywhere on the file system, but it must be an absolute file
+name--it is the caller's responsibility to ensure that it is an absolute
+file name.  Return #t on success."
+  boolean)
+
 
 ;;;
 ;;; Store paths.