[bug#62401] Automatically mapping services from System to Home

[Ludovic Courtès]

One idea I toyed with is automatic translation of service types from
System to Home.  The service itself would look like this:

--8<---------------cut here---------------start------------->8---
(define-module (gnu home services syncthing)
  #:use-module (gnu home services)
  #:use-module (gnu services syncthing)
  #:export (home-syncthing-service-type)
  #:re-export (syncthing-configuration
               syncthing-configuration?))

(define home-syncthing-service-type
  (system-service-type->home-service-type syncthing-service-type))
--8<---------------cut here---------------end--------------->8---

The code to do that is attached below.  The key here is that we’d define
mappings, like:

  (define-service-type-mapping
    shepherd-root-service-type => home-shepherd-service-type)

The rest of the service type graph would be automatically constructed
from this.

I feel like it would be worth pursuing this path so that there’s as
little duplication as possible between Home and System.

OTOH, it doesn’t take care of things like #:user in
‘make-forkexec-constructor’ calls and the like.

Thoughts?

Ludo’.

diff --git a/gnu/home/services.scm b/gnu/home/services.scm
index b7ea6f08dd..b32e7395b1 100644
--- a/gnu/home/services.scm
+++ b/gnu/home/services.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,8 +32,10 @@ (define-module (gnu home services)
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (guix modules)
+  #:use-module (guix memoization)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
 
   #:export (home-service-type
             home-profile-service-type
@@ -46,6 +49,9 @@ (define-module (gnu home services)
             fold-home-service-types
             home-provenance
 
+            define-service-type-mapping
+            system-service-type->home-service-type
+
             %initialize-gettext)
 
   #:re-export (service
@@ -396,6 +402,77 @@ (define home-activation-service-type
 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)
+  (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)
+       (location (service-type-location type))
+       (extensions (filter-map rewrite (service-type-extensions type))))))
+
+  replace)
+
+;; (define (service-type-extensions-rewriting replacements)
+;;   (define replace
+;;     (let ((replacements (alist->vhash replacements hashq)))
+;;       (lambda (type)
+;;         (match (vhash-assq type replacements)
+;;           (#f type)
+;;           ((_ . replacement) replacement)))))
+
+;;   (service-type-mapping replace))
+
+(define system-service-type->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 %system/home-service-type-mapping
+  (make-hash-table))
+
+(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))
+
+;; (define system->home-service-type
+;;   (service-type-extensions-rewriting
+;;    `((,system-service-type . ,home-service-type)
+;;      (,activation-service-type . ,home-activation-service-type)
+;;      (,shepherd-root-service-type . ,home-shepherd-service-type))))
+

 ;;;
 ;;; On-change.
diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm
index 7a9cc064bb..21b73d8cdf 100644
--- a/gnu/home/services/shepherd.scm
+++ b/gnu/home/services/shepherd.scm
@@ -131,4 +131,5 @@ (define-public home-shepherd-service-type
                 (default-value (home-shepherd-configuration))
                 (description "Configure and install userland Shepherd.")))
 
-
+(define-service-type-mapping
+  shepherd-root-service-type => home-shepherd-service-type)
diff --git a/gnu/services/syncthing.scm b/gnu/services/syncthing.scm
index 7c3d5b027d..130a87705e 100644
--- a/gnu/services/syncthing.scm
+++ b/gnu/services/syncthing.scm
@@ -57,7 +57,7 @@ (define syncthing-shepherd-service
       (shepherd-service
        (provision (list (string->symbol (string-append "syncthing-" user))))
        (documentation "Run syncthing.")
-       (requirement '(loopback))
+       ;; (requirement '(loopback))
        (start #~(make-forkexec-constructor
                  (append (list (string-append #$syncthing "/bin/syncthing")
                                "-no-browser"