01/08: services: Add 'gc-root-service-type'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e0b47290a704c954d00d86e0c120fe44946f29f9
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jun 19 21:29:01 2016 +0200

    services: Add 'gc-root-service-type'.
    
    * gnu/services.scm (gc-roots->system-entry): New procedure.
    (gc-root-service-type): New variable.
---
 gnu/services.scm |   28 ++++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)

diff --git a/gnu/services.scm b/gnu/services.scm
index 9268c51..50e76df 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -73,6 +73,7 @@
             setuid-program-service-type
             profile-service-type
             firmware-service-type
+            gc-root-service-type
 
             %boot-service
             %activation-service
@@ -489,6 +490,33 @@ kernel."
                 (compose concatenate)
                 (extend append)))
 
+(define (gc-roots->system-entry roots)
+  "Return an entry in the system's output containing symlinks to ROOTS."
+  (mlet %store-monad ((entry (gexp->derivation
+                              "gc-roots"
+                              #~(let ((roots '#$roots))
+                                  (mkdir #$output)
+                                  (chdir #$output)
+                                  (for-each symlink
+                                            roots
+                                            (map number->string
+                                                 (iota (length roots))))))))
+    (return (if (null? roots)
+                '()
+                `(("gc-roots" ,entry))))))
+
+(define gc-root-service-type
+  ;; A service to associate extra garbage-collector roots to the system.  This
+  ;; is a simple hack that guarantees that the system retains references to
+  ;; the given list of roots.  Roots must be "lowerable" objects like
+  ;; packages, or derivations.
+  (service-type (name 'gc-roots)
+                (extensions
+                 (list (service-extension system-service-type
+                                          gc-roots->system-entry)))
+                (compose concatenate)
+                (extend append)))
+
 
 ;;;
 ;;; Service folding.