From 161d010d40aa31f59b2ad3ecca12efda7c70366d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 6 Aug 2023 18:25:22 +0200
Subject: [PATCH] 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.
---
 gnu/home/services.scm          | 69 +++++++++++++++++++++++++++++++++-
 gnu/home/services/shepherd.scm |  4 +-
 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:
 ;;;
@@ -513,6 +519,67 @@ directory.  @command{activate} script automatically called during
 reconfiguration or generation switching.  This service can be extended
 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)