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.
This commit is contained in:
Ludovic Courtès 2023-08-06 18:25:22 +02:00
parent dff7d2468f
commit 161d010d40
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 71 additions and 2 deletions

View file

@ -33,6 +33,7 @@ (define-module (gnu home services)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (guix i18n) #:use-module (guix i18n)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix memoization)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -63,11 +64,16 @@ (define-module (gnu home services)
lookup-home-service-types lookup-home-service-types
home-provenance home-provenance
define-service-type-mapping
system->home-service-type
%initialize-gettext) %initialize-gettext)
#:re-export (service #:re-export (service
service-type service-type
service-extension)) service-extension
for-home
for-home?))
;;; Comment: ;;; Comment:
;;; ;;;
@ -513,6 +519,67 @@ (define home-activation-service-type
reconfiguration or generation switching. This service can be extended reconfiguration or generation switching. This service can be extended
with one gexp, but many times, and all gexps must be idempotent."))) 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. ;;; On-change.

View file

@ -141,7 +141,7 @@ (define (ensure-shepherd-gexp config)
(define (shepherd-xdg-configuration-files config) (define (shepherd-xdg-configuration-files config)
`(("shepherd/init.scm" ,(home-shepherd-configuration-file 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) (service-type (name 'home-shepherd)
(extensions (extensions
(list (service-extension (list (service-extension
@ -168,4 +168,6 @@ (define-public home-shepherd-service-type
(default-value (home-shepherd-configuration)) (default-value (home-shepherd-configuration))
(description "Configure and install userland Shepherd."))) (description "Configure and install userland Shepherd.")))
(define-service-type-mapping
shepherd-root-service-type => home-shepherd-service-type)