X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/09ec508a4c14d1bc09622d98f796548d79ab0552..d5b0c9024ed174907aed4816b2607ada814a035c:/gnu/services.scm diff --git a/gnu/services.scm b/gnu/services.scm index 9268c51dd8..693a7f8001 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -25,6 +25,7 @@ #:use-module (guix profiles) #:use-module (guix sets) #:use-module (guix ui) + #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (srfi srfi-1) @@ -50,6 +51,7 @@ service-kind service-parameters + simple-service modify-services service-back-edges fold-services @@ -73,6 +75,7 @@ setuid-program-service-type profile-service-type firmware-service-type + gc-root-service-type %boot-service %activation-service @@ -140,6 +143,13 @@ (type service-kind) (parameters service-parameters)) +(define (simple-service name target value) + "Return a service that extends TARGET with VALUE. This works by creating a +singleton service type NAME, of which the returned service is an instance." + (let* ((extension (service-extension target identity)) + (type (service-type (name name) + (extensions (list extension))))) + (service type value))) (define-syntax %modify-service (syntax-rules (=>) @@ -237,42 +247,33 @@ directory." (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. @@ -308,10 +309,10 @@ file." 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 @@ -320,45 +321,29 @@ ACTIVATION-SCRIPT-TYPE." (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." - (define %modules - '((gnu build activation) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix build utils) - (guix build syscalls) - (guix build bournish) - (guix elf))) - (define (service-activations) ;; Return the activation scripts for SERVICES. (mapm %store-monad (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 (source-module-closure + '((gnu build activation))) + #~(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." @@ -489,6 +474,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.