;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
setuid-program-service-type
profile-service-type
firmware-service-type
+ gc-root-service-type
%boot-service
%activation-service
;;; A service type describe how its instances extend instances of other
;;; service types. For instance, some services extend the instance of
;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
-;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of
-;;; <dmd-service>.
+;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
+;;; <shepherd-service>.
;;;
;;; When applicable, the service type defines how it can itself be extended,
;;; by providing one procedure to compose extensions, and one procedure to
(define-syntax modify-services
(syntax-rules ()
- "Modify the services listed in SERVICES according to CLAUSES. Each clause
-must have the form:
+ "Modify the services listed in SERVICES according to CLAUSES and return
+the resulting list of services. Each clause must have the form:
(TYPE VARIABLE => BODY)
(define (compute-boot-script _ mexps)
(mlet %store-monad ((gexps (sequence %store-monad mexps)))
(gexp->file "boot"
- ;; Clean up and activate the system, then spawn dmd.
+ ;; Clean up and activate the system, then spawn shepherd.
#~(begin #$@gexps))))
(define (boot-script-entry mboot)
(define (cleanup-gexp _)
"Return as a monadic value a gexp to clean up /tmp and similar places upon
boot."
- (define %modules
- '((guix build utils)))
-
- (mlet %store-monad ((modules (imported-modules %modules))
- (compiled (compiled-modules %modules)))
- (return #~(begin
- (eval-when (expand load eval)
- ;; Make sure 'use-modules' below succeeds.
- (set! %load-path (cons #$modules %load-path))
- (set! %load-compiled-path
- (cons #$compiled %load-compiled-path)))
-
- (use-modules (guix build utils))
-
- ;; Clean out /tmp and /var/run.
- ;;
- ;; XXX This needs to happen before service activations, so it
- ;; has to be here, but this also implicitly assumes that /tmp
- ;; and /var/run are on the root partition.
- (letrec-syntax ((fail-safe (syntax-rules ()
- ((_ exp rest ...)
- (begin
- (catch 'system-error
- (lambda () exp)
- (const #f))
- (fail-safe rest ...)))
- ((_)
- #t))))
- ;; Ignore I/O errors so the system can boot.
- (fail-safe
- (delete-file-recursively "/tmp")
- (delete-file-recursively "/var/run")
- (mkdir "/tmp")
- (chmod "/tmp" #o1777)
- (mkdir "/var/run")
- (chmod "/var/run" #o755)))))))
+ (with-monad %store-monad
+ (with-imported-modules '((guix build utils))
+ (return #~(begin
+ (use-modules (guix build utils))
+
+ ;; Clean out /tmp and /var/run.
+ ;;
+ ;; XXX This needs to happen before service activations, so it
+ ;; has to be here, but this also implicitly assumes that /tmp
+ ;; and /var/run are on the root partition.
+ (letrec-syntax ((fail-safe (syntax-rules ()
+ ((_ exp rest ...)
+ (begin
+ (catch 'system-error
+ (lambda () exp)
+ (const #f))
+ (fail-safe rest ...)))
+ ((_)
+ #t))))
+ ;; Ignore I/O errors so the system can boot.
+ (fail-safe
+ (delete-file-recursively "/tmp")
+ (delete-file-recursively "/var/run")
+ (mkdir "/tmp")
+ (chmod "/tmp" #o1777)
+ (mkdir "/var/run")
+ (chmod "/var/run" #o755))))))))
(define cleanup-service-type
;; Service that cleans things up in /tmp and similar.
(chdir #$output)
#$@(map (match-lambda
((target source)
- #~(symlink #$source #$target)))
+ #~(begin
+ ;; Stat the source to abort early if it
+ ;; does not exist.
+ (stat #$source)
+
+ (symlink #$source #$target))))
files))))
(define (directory-union name things)
one)
(_
(computed-file name
- #~(begin
- (use-modules (guix build union))
- (union-build #$output '#$things))
- #:modules '((guix build union))))))
+ (with-imported-modules '((guix build union))
+ #~(begin
+ (use-modules (guix build union))
+ (union-build #$output '#$things)))))))
(define* (activation-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
(gnu build file-systems)
(guix build utils)
(guix build syscalls)
+ (guix build bournish)
(guix elf)))
(define (service-activations)
(cut gexp->file "activate-service" <>)
gexps))
- (mlet* %store-monad ((actions (service-activations))
- (modules (imported-modules %modules))
- (compiled (compiled-modules %modules)))
+ (mlet* %store-monad ((actions (service-activations)))
(gexp->file "activate"
- #~(begin
- (eval-when (expand load eval)
- ;; Make sure 'use-modules' below succeeds.
- (set! %load-path (cons #$modules %load-path))
- (set! %load-compiled-path
- (cons #$compiled %load-compiled-path)))
-
- (use-modules (gnu build activation))
+ (with-imported-modules %modules
+ #~(begin
+ (use-modules (gnu build activation))
- ;; Make sure /bin/sh is valid and current.
- (activate-/bin/sh
- (string-append #$(canonical-package bash) "/bin/sh"))
+ ;; Make sure /bin/sh is valid and current.
+ (activate-/bin/sh
+ (string-append #$(canonical-package bash) "/bin/sh"))
- ;; Run the services' activation snippets.
- ;; TODO: Use 'load-compiled'.
- (for-each primitive-load '#$actions)
+ ;; Run the services' activation snippets.
+ ;; TODO: Use 'load-compiled'.
+ (for-each primitive-load '#$actions)
- ;; Set up /run/current-system.
- (activate-current-system)))))
+ ;; Set up /run/current-system.
+ (activate-current-system))))))
(define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS."
(define (packages->profile-entry packages)
"Return a system entry for the profile containing PACKAGES."
(mlet %store-monad ((profile (profile-derivation
- (manifest (map package->manifest-entry
- (delete-duplicates packages eq?))))))
+ (packages->manifest
+ (delete-duplicates packages eq?)))))
(return `(("profile" ,profile)))))
(define profile-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)))
+
\f
;;;
;;; Service folding.
HCoop / jackhill / guix / guix.git / blobdiff