ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

services: Add 'gc-root-service-type'.

Browse source 
* gnu/services.scm (gc-roots->system-entry): New procedure.
(gc-root-service-type): New variable.
This commit is contained in:
Ludovic Courtès 2016-06-19 21:29:01 +02:00
parent 3ebba94d45
commit e0b47290a7
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 28 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
gnu/services.scm
View file

@ -73,6 +73,7 @@ (define-module (gnu services)
setuid-program-service-type
profile-service-type
firmware-service-type
gc-root-service-type
%boot-service
%activation-service
@ -489,6 +490,33 @@ (define firmware-service-type
(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.