summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2023-08-06 18:25:22 +0200
committerLudovic Courtès <ludo@gnu.org>2023-08-20 22:48:47 +0200
commit161d010d40aa31f59b2ad3ecca12efda7c70366d (patch)
treec929f3d01df335fe500b4fcf8c8f4e1d9cce4bbf
parentdff7d2468ffe9d01b25662544af380e1794ac55a (diff)
home: services: Support mapping of System services to Home services.
* gnu/home/services.scm (service-type-mapping) (system->home-service-type): New procedures. (define-service-type-mapping, define-service-type-mappings): New macros. (%system/home-service-type-mapping): New variable. <top level>: Use 'define-service-type-mappings'. * gnu/home/services/shepherd.scm <top level>: Likewise.
-rw-r--r--gnu/home/services.scm69
-rw-r--r--gnu/home/services/shepherd.scm4
2 files changed, 71 insertions, 2 deletions
diff --git a/gnu/home/services.scm b/gnu/home/services.scm
index 042eba4780..8d53f2f4d3 100644
--- a/gnu/home/services.scm
+++ b/gnu/home/services.scm
@@ -33,6 +33,7 @@
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (guix modules)
+ #:use-module (guix memoization)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (ice-9 match)
@@ -63,11 +64,16 @@
lookup-home-service-types
home-provenance
+ define-service-type-mapping
+ system->home-service-type
+
%initialize-gettext)
#:re-export (service
service-type
- service-extension))
+ service-extension
+ for-home
+ for-home?))
;;; Comment:
;;;
@@ -515,6 +521,67 @@ with one gexp, but many times, and all gexps must be idempotent.")))
;;;
+;;; Service type graph rewriting.
+;;;
+
+(define (service-type-mapping proc)
+ "Return a procedure that applies PROC to map a service type graph to another
+one."
+ (define (rewrite extension)
+ (match (proc (service-extension-target extension))
+ (#f #f)
+ (target
+ (service-extension target
+ (service-extension-compute extension)))))
+
+ (define replace
+ (mlambdaq (type)
+ (service-type
+ (inherit type)
+ (name (symbol-append 'home- (service-type-name type)))
+ (location (service-type-location type))
+ (extensions (filter-map rewrite (service-type-extensions type))))))
+
+ replace)
+
+(define %system/home-service-type-mapping
+ ;; Mapping of System to Home services.
+ (make-hash-table))
+
+(define system->home-service-type
+ ;; Map the given System service type to the corresponding Home service type.
+ (let ()
+ (define (replace type)
+ (define replacement
+ (hashq-ref %system/home-service-type-mapping type
+ *unspecified*))
+
+ (if (eq? replacement *unspecified*)
+ type
+ replacement))
+
+ (service-type-mapping replace)))
+
+(define-syntax define-service-type-mapping
+ (syntax-rules (=>)
+ ((_ system-type => home-type)
+ (hashq-set! %system/home-service-type-mapping
+ system-type home-type))))
+
+(define-syntax define-service-type-mappings
+ (syntax-rules (=>)
+ ((_ (system-type => home-type) ...)
+ (begin
+ (define-service-type-mapping system-type => home-type)
+ ...))))
+
+(define-service-type-mappings
+ (system-service-type => home-service-type)
+ (activation-service-type => home-activation-service-type)
+ (profile-service-type => home-profile-service-type))
+
+
+;;;
;;; On-change.
;;;
diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm
index 5585ef61b2..bd068c37fc 100644
--- a/gnu/home/services/shepherd.scm
+++ b/gnu/home/services/shepherd.scm
@@ -141,7 +141,7 @@ as shepherd package."
(define (shepherd-xdg-configuration-files config)
`(("shepherd/init.scm" ,(home-shepherd-configuration-file config))))
-(define-public home-shepherd-service-type
+(define home-shepherd-service-type
(service-type (name 'home-shepherd)
(extensions
(list (service-extension
@@ -168,4 +168,6 @@ as shepherd package."
(default-value (home-shepherd-configuration))
(description "Configure and install userland Shepherd.")))
+(define-service-type-mapping
+ shepherd-root-service-type => home-shepherd-service-type)