From cc4645659896113cb8677110a1ed768405709296 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 8 Apr 2014 18:21:26 +0200
Subject: [PATCH] hydra-eval-guile-jobs: Register derivations as GC roots.

* src/script/hydra-eval-guile-jobs.in (register-gc-root): New
  procedure.
  (job-evaluations->sxml): Add #:gc-roots-dir parameter.  Call
  'register-gc-root'.
  (job-evaluations->xml): Add #:gc-roots-dir parameter; pass it to
  'job-evaluations->sxml'.
  (eval-guile-jobs): Warn when --gc-roots-dir isn't passed.  Pass
  GC-ROOTS-DIR to 'job-evaluations->xml'.
---
 src/script/hydra-eval-guile-jobs.in | 27 +++++++++++++++++++++++----
 1 file changed, 23 insertions(+), 4 deletions(-)

diff --git a/src/script/hydra-eval-guile-jobs.in b/src/script/hydra-eval-guile-jobs.in
index 2deb3513..01f3220b 100644
--- a/src/script/hydra-eval-guile-jobs.in
+++ b/src/script/hydra-eval-guile-jobs.in
@@ -71,7 +71,14 @@ fails in our case, leading to the creation of empty (guix ...) modules."
         (string-drop-right d 4)
         d)))
 
-(define (job-evaluations->sxml jobs)
+(define (register-gc-root drv roots-dir)
+  "Register a permanent garbage collector root under ROOTS-DIR for DRV."
+  (let ((root (string-append roots-dir "/" (basename drv))))
+    (unless (file-exists? root)
+      (symlink drv root))))
+
+(define* (job-evaluations->sxml jobs
+                                #:key gc-roots-dir)
   "Return the hydra-eval-jobs SXML form for the result of JOBS, a list of
 symbol/thunk pairs."
   `(*TOP*
@@ -93,6 +100,11 @@ symbol/thunk pairs."
                     (_
                      '())))
 
+                (when gc-roots-dir
+                  ;; Register DRV as a GC root so that it's not collected by
+                  ;; the time 'hydra-build' attempts to build it.
+                  (register-gc-root drv gc-roots-dir))
+
                 ;; XXX: Add <arg ...> tags?
                 `(job (@ (jobName ,name)
                          (drvPath ,drv)
@@ -139,9 +151,11 @@ symbol/thunk pairs."
                       "\n"))))
             jobs))))
 
-(define (job-evaluations->xml jobs port)
+(define* (job-evaluations->xml jobs port
+                               #:key gc-roots-dir)
   (set-port-encoding! port "UTF-8")
-  (sxml->xml (job-evaluations->sxml jobs) port))
+  (sxml->xml (job-evaluations->sxml jobs #:gc-roots-dir gc-roots-dir)
+             port))
 
 
 ;;;
@@ -226,4 +240,9 @@ directory or #f."
     (let* ((entry (eval entry %user-module))
            (store ((guix-variable 'store 'open-connection)))
            (jobs  (entry store args)))
-      (job-evaluations->xml jobs (current-output-port)))))
+      (unless (string? gc-roots-dir)
+        (format (current-error-port)
+                "warning: --gc-roots-dir not specified~%"))
+
+      (job-evaluations->xml jobs (current-output-port)
+                            #:gc-roots-dir gc-roots-dir))))