Subject: [PATCH 1/1] home: services: Add state services.

From: Oleg Pykhalov <[email-masked]>
Date: Sat, 23 Oct 2021 21:06:54 +0300

* gnu/home.scm (home-environment-compiler): New procedure.
* gnu/home/services/state.scm: New file.
* doc/guix.texi (State Home Services): Document this.
* gnu/home/services/version-control.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add those.
* gnu/home/services/utils.scm
(ini-config?, default-ini-format-section, generic-serialize-ini-config,
generic-serialize-git-ini-config): New procedures.
* gnu/tests/version-control.scm (run-home-state-git-test): New procedure.
(%home-state-git-os, %test-home-state-git): New variables.
* guix/scripts/home.scm
(not-config?, switch-home-program, switch-to-home, local-eval): New procedures.
(save-load-path-excursion): New macro.
(switch-home-program): Use switch-to-home procedure.
* gnu/tests/rsync.scm (run-home-state-rsync-test): New procedures.
(%home-state-rsync-os, %test-home-state-rsync): New variables.
---
 doc/guix.texi                         |  32 ++
 gnu/home.scm                          |  12 +
 gnu/home/services/state.scm           | 210 ++++++++++++
 gnu/home/services/utils.scm           |  81 ++++-
 gnu/home/services/version-control.scm | 442 ++++++++++++++++++++++++++
 gnu/local.mk                          |   2 +
 gnu/tests/rsync.scm                   | 158 ++++++++-
 gnu/tests/version-control.scm         | 140 +++++++-
 guix/scripts/home.scm                 | 100 +++++-
 9 files changed, 1163 insertions(+), 14 deletions(-)
 create mode 100644 gnu/home/services/state.scm
 create mode 100644 gnu/home/services/version-control.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 63bb22764a..c79f3acfa3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -35548,6 +35548,7 @@ services)}.
 * Shells: Shells Home Services.          POSIX shells, Bash, Zsh.
 * Mcron: Mcron Home Service.             Scheduled User's Job Execution.
 * Shepherd: Shepherd Home Service.       Managing User's Daemons.
+* State: State Home Services.            Managing User's states.
 @end menu
 @c In addition to that Home Services can provide
 
@@ -35875,6 +35876,37 @@ mechanism instead (@pxref{Shepherd Services}).
 @end table
 @end deftp
 
+@node State Home Services
+@subsection Managing User's states
+
+@cindex state
+@cindex rsync
+@cindex git
+@cindex hg
+
+@command{herd init state} will create all the neccessary dirs, will clone the
+Git repos with projects you work on, restore wallpapers dir from backup
+server via Rsync and so on.  That helps at least control and init state
+your software depends on, when you switching to new machine for example.
+
+@defvr {Scheme Variable} home-state-service-type
+This is the type of the @code{state} home service, whose value is a list
+of @code{shepherd-service} objects.
+@end defvr
+
+The following examples demonstrate Git and Rsync configuration:
+
+@example
+(home-environment
+ (services
+  (list
+   (service home-state-service-type
+            (list (state-git "/home/alice/guix-maintenance"
+                             "https://git.savannah.gnu.org/git/guix/maintenance.git")
+                  (state-rsync "/home/alice/output"
+                               "rsync://localhost:873/files/input"))))))
+@end example
+
 @node Invoking guix home
 @section Invoking @code{guix home}
 
diff --git a/gnu/home.scm b/gnu/home.scm
index d8134693e5..87d4d54b8e 100644
--- a/gnu/home.scm
+++ b/gnu/home.scm
@@ -23,8 +23,10 @@ (define-module (gnu home)
   #:use-module (gnu home services xdg)
   #:use-module (gnu home services fontutils)
   #:use-module (gnu services)
+  #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix diagnostics)
+  #:use-module (guix store)
 
   #:export (home-environment
             home-environment?
@@ -104,3 +106,13 @@ (define* (home-environment-with-provenance he config-file)
     (inherit he)
     (services (cons (service home-provenance-service-type config-file)
                     (home-environment-user-services he)))))
+
+(define-gexp-compiler (home-environment-compiler (he <home-environment>)
+                                                 system target)
+  ((store-lift
+    (lambda (store)
+      ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
+      ;; 'home-environment-derivation'.
+      (run-with-store store (home-environment-derivation he)
+                      #:system system
+                      #:target target)))))
diff --git a/gnu/home/services/state.scm b/gnu/home/services/state.scm
new file mode 100644
index 0000000000..f78751b10f
--- /dev/null
+++ b/gnu/home/services/state.scm
@@ -0,0 +1,210 @@
+(define-module (gnu home services state)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services utils)
+  #:use-module (gnu home services shepherd)
+  #:use-module (gnu home services version-control)
+  #:use-module (gnu packages rsync)
+  #:use-module (gnu packages version-control)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu packages ssh)
+  #:use-module (guix packages)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix modules)
+  #:use-module (guix records)
+
+  #:export (home-state-service-type
+            state-generic
+            state-git
+            state-hg
+	    state-rsync))
+
+(define* (state-hg path remote #:key (config #f))
+  (state-generic
+   path
+   #:init-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (car (action self 'metadata)))
+              (path (assoc-ref meta 'path))
+              (remote (assoc-ref meta 'remote)))
+         (format #t "Initializing ~a.\n" self)
+         (let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
+                       #$(file-append mercurial "/bin/hg") "clone" remote path)))
+           (waitpid WAIT_ANY)
+           (display ((@@ (ice-9 rdelim) read-delimited) "" port))
+           (close-port port))
+
+         (when '#$config
+           (call-with-output-file (string-append path "/.hg/hgrc")
+             (lambda (port) (display (string-append
+                                      #$@(serialize-hg-config config)) port))))))
+   #:additional-metadata `((remote . ,remote)
+                           (general-sync? . #f))))
+
+(define* (state-git path remote #:key (config #f))
+  (state-generic
+   path
+   #:init-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (car (action self 'metadata)))
+	      (path (assoc-ref meta 'path))
+	      (remote (assoc-ref meta 'remote)))
+	 (format #t "Initializing ~a.\n" self)
+	 ;; TODO: revisit git clone implementation
+	 ;; FIXME: Hang up shepherd if username/password asked
+	 (let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
+		       #$(file-append git "/bin/git") "clone" remote path)))
+	   (waitpid WAIT_ANY)
+	   (display ((@@ (ice-9 rdelim) read-delimited) "" port))
+	   (close-port port))
+
+	 (when #$config
+	   (call-with-output-file (string-append path "/.git/config")
+	     (lambda (port) (display #$config port))))))
+   #:additional-metadata `((remote . ,remote)
+			   (general-sync? . #f))))
+
+(define* (state-rsync path remote)
+  (state-generic
+   path
+   #:init-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (car (action self 'metadata)))
+	      (path (assoc-ref meta 'path))
+	      (remote (assoc-ref meta 'remote)))
+	 (format #t "Initializing ~a.\n" self)
+	 ;; TODO: revisit git clone implementation
+	 (let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
+		       #$(file-append rsync "/bin/rsync") "-aP" remote path)))
+	   (waitpid WAIT_ANY)
+	   (display ((@@ (ice-9 rdelim) read-delimited) "" port))
+	   (close-port port))))
+   #:sync-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (car (action self 'metadata)))
+	      (path (assoc-ref meta 'path))
+	      (remote (assoc-ref meta 'remote)))
+	 (format #t "Synchronizing ~a.\n" self)
+	 (let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
+		       #$(file-append rsync "/bin/rsync") "-aP" path remote)))
+	   (waitpid WAIT_ANY)
+	   (display ((@@ (ice-9 rdelim) read-delimited) "" port))
+	   (close-port port))))
+   #:additional-metadata `((remote . ,remote)
+			   (general-sync? . #t))))
+
+(define* (state-generic
+	  path
+	  #:key
+	  (init-gexp
+	   #~(lambda* (_ self)
+	       (let ((path (assoc-ref (car (action self 'metadata)) 'path)))
+		 (format #t "Initializing ~a.\n" self)
+		 (format #t "Creating ~a directory..." path)
+		 (mkdir-p path)
+		 (display " done\n"))))
+	  (sync-gexp
+	   #~(lambda* (_ self)
+	       (let ((path (assoc-ref (car (action self 'metadata)) 'path)))
+		 (format #t "Synchronizing ~a.\n" self)
+		 (format #t "Nothing to synchronize.\n"))))
+	  (additional-metadata '((general-sync? . #f))))
+  "A function which returns a shepherd-service with all required
+actions for state management, should be used as a basis for other
+state related items like git-state, rsync-state, etc."
+  (let ((self (string->symbol
+	       (format #f "state-~a" path))))
+    (shepherd-service
+     (documentation (format #f "Managing state at ~a." path))
+     (provision (list self))
+     (auto-start? #f)
+     (start #~(lambda ()
+		(if (car (action '#$self 'state-exists?))
+		    #t
+		    (begin
+		      (format #t "~a is not initilized yet." '#$self)
+		      #f))))
+     (actions (list
+	       (shepherd-action
+		(name 'state-exists?)
+		(documentation "Check if state file/directory exists.")
+		(procedure #~(lambda* (#:rest rest)
+			       (file-exists? #$path))))
+	       (shepherd-action
+		(name 'unchecked-init)
+		(documentation "Do not use this action directly.")
+		(procedure init-gexp))
+	       (shepherd-action
+		(name 'metadata)
+		(documentation "Returns metadata related to the state.")
+		(procedure #~(lambda* _
+			       (append
+				'((path . #$path)
+				  (self . #$self))
+				'#$additional-metadata))))
+	       (shepherd-action
+		(name 'sync)
+		(documentation "Sync the state.")
+		(procedure sync-gexp))
+	       (shepherd-action
+		(name 'init)
+		(documentation "Generic initialize.")
+		(procedure #~(lambda* (#:rest rest)
+			       (if (car (action '#$self 'state-exists?))
+				   (format #t "~a already initialized.\n" '#$self)
+				   (begin
+				     (action '#$self 'unchecked-init '#$self)
+				     (start '#$self)))))))))))
+
+(define (add-shepherd-services services)
+  (let* ((service-names
+	  (map
+	   (lambda (service) (car (shepherd-service-provision service)))
+	   services)))
+    (append
+     services
+     (list
+      (shepherd-service
+       (documentation "Init, update and maybe destroy state.")
+       (provision '(state))
+       (auto-start? #t)
+       (start #~(lambda ()
+		  (map (lambda (name)
+			 (when (car (action name 'state-exists?))
+			   (start name)))
+		       '#$service-names)))
+       (actions (list
+		 (shepherd-action
+		  (name 'sync)
+		  (documentation
+                   "Sync all the state. Highly dependent on state type.")
+		  (procedure
+		   #~(lambda _
+		       (map (lambda (name)
+			      (when (assoc-ref (car (action name 'metadata))
+					       'general-sync?)
+				(action name 'sync name)))
+			    '#$service-names))))
+		 (shepherd-action
+		  (name 'init)
+		  (documentation "Initialize all the state.")
+		  (procedure #~(lambda _
+				 (map (lambda (name)
+					(when (not (car (action name 'state-exists?)))
+					  (action name 'init)
+					  (start name)))
+				      '#$service-names)))))))))))
+
+(define home-state-service-type
+  (service-type (name 'home-state)
+                (extensions
+                 (list (service-extension
+                        home-shepherd-service-type
+                        add-shepherd-services)))
+                (default-value '())
+		(compose concatenate)
+		(extend append)
+                (description "A toolset for initializing state.")))
diff --git a/gnu/home/services/utils.scm b/gnu/home/services/utils.scm
index cea75ee896..8f2122dda9 100644
--- a/gnu/home/services/utils.scm
+++ b/gnu/home/services/utils.scm
@@ -21,11 +21,17 @@ (define-module (gnu home services utils)
   #:use-module (ice-9 string-fun)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (gnu services configuration)
 
   #:export (maybe-object->string
             object->snake-case-string
             object->camel-case-string
-            list->human-readable-list))
+            list->human-readable-list
+
+            ini-config?
+            generic-serialize-ini-config
+            generic-serialize-git-ini-config))
 
 (define (maybe-object->string object)
   "Like @code{object->string} but don't do anyting if OBJECT already is
@@ -103,3 +109,76 @@ (define* (list->human-readable-list lst
                      word
                      (maybe-object->string (proc (last lst)))))))
 
+
+;;;
+;;; Serializers.
+;;;
+
+(define ini-config? list?)
+(define (generic-serialize-ini-config-section section proc)
+  "Format a section from SECTION for an INI configuration.
+Apply the procedure PROC on SECTION after it has been converted to a string"
+  (format #f "[~a]\n" (proc section)))
+
+(define default-ini-format-section
+  (match-lambda
+    ((section subsection)
+     (string-append (maybe-object->string section) " "
+                    (maybe-object->string subsection)))
+    (section
+     (maybe-object->string section))))
+
+(define* (generic-serialize-ini-config
+          #:key
+          (combine-ini string-join)
+          (combine-alist string-append)
+          (combine-section-alist string-append)
+          (format-section default-ini-format-section)
+          serialize-field
+          fields)
+  "Create an INI configuration from nested lists FIELDS.  This uses
+@code{generic-serialize-ini-config-section} and @{generic-serialize-alist} to
+serialize the section and the association lists, respectively.
+
+@example
+(generic-serialize-ini-config
+ #:serialize-field (lambda (a b) (format #f \"~a = ~a\n\" a b))
+ #:format-section (compose string-capitalize symbol->string)
+ #:fields '((application ((key . value)))))
+@end example
+
+@result{} \"[Application]\nkey = value\n\""
+  (combine-ini
+   (map (match-lambda
+          ((section alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section section format-section)
+            (generic-serialize-alist combine-alist serialize-field alist))))
+        fields)
+   "\n"))
+
+(define* (generic-serialize-git-ini-config
+          #:key
+          (combine-ini string-join)
+          (combine-alist string-append)
+          (combine-section-alist string-append)
+          (format-section default-ini-format-section)
+          serialize-field
+          fields)
+  "Like @code{generic-serialize-ini-config}, but the section can also
+have a @dfn{subsection}.  FORMAT-SECTION will take a list of two
+elements: the section and the subsection."
+  (combine-ini
+   (map (match-lambda
+          ((section subsection alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section
+             (list section subsection) format-section)
+            (generic-serialize-alist combine-alist serialize-field alist)))
+          ((section alist)
+           (combine-section-alist
+            (generic-serialize-ini-config-section section format-section)
+            (generic-serialize-alist combine-alist serialize-field alist))))
+        fields)
+   "\n"))
+
diff --git a/gnu/home/services/version-control.scm b/gnu/home/services/version-control.scm
new file mode 100644
index 0000000000..afc9c539a7
--- /dev/null
+++ b/gnu/home/services/version-control.scm
@@ -0,0 +1,442 @@
+(define-module (gnu home services version-control)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services utils)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu packages version-control)
+  #:use-module (guix packages)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module ((guix import utils) #:select (flatten))
+
+  #:export (home-git-configuration
+            home-git-extension
+            home-git-service-type
+            serialize-git-config
+
+            home-hg-configuration
+            home-hg-extension
+            serialize-hg-config
+            home-hg-service-type))
+
+;;; Commentary:
+;;;
+;;; Version control related services.
+;;;
+;;; Code:
+
+;;;
+;;; Git.
+;;;
+;;; (service home-git-service-type
+;;;      (home-git-configuration
+;;;       (attributes
+;;;        '((* . text=auto)
+;;;          (*.sh . "text eol=lf")))
+;;;       (ignore
+;;;        '("*.so" "*.o"))
+;;;       (ignore-extra-content
+;;;        "*.dll\n*.exe\n")
+;;;       (config
+;;;        `((http "https://weak.example.com"
+;;;                ((ssl-verify . #f)))
+;;;          (gpg
+;;;           ((program . ,(file-append gnupg "/bin/gpg"))))
+;;;          (sendmail
+;;;           ((annotate . #t))))
+;;;        (config-extra-content (slurp-file-gexp
+;;;                                (local-file "./gitconfig")))))
+;;;
+;;; (simple-service
+;;;  'add-something-to-git
+;;;  home-git-service-type
+;;;  (home-git-extension
+;;;   (config
+;;;     `((sendmail
+;;;        ((annotate . #t)))))))
+
+
+(define (uglify-field-name field-name)
+  "Convert symbol FIELD-NAME to a camel case string.
+@code{symbol-name} => \"@code{symbolName}\"."
+  (let* ((str (symbol->string field-name))
+         (spl-str (string-split str #\-)))
+    (apply string-append
+           (car spl-str)
+           (map string-capitalize (cdr spl-str)))))
+
+(define (serialize-field field-name val)
+   (cond
+    ((boolean? val) (serialize-boolean field-name val))
+    (else
+     (list (format #f "\t~a = " (uglify-field-name field-name))
+           val "\n"))))
+
+(define (serialize-alist field-name val)
+  (generic-serialize-alist append serialize-field val))
+
+(define (serialize-boolean field-name val)
+  (serialize-field field-name (if val "true" "false")))
+
+(define serialize-string serialize-field)
+(define git-config? list?)
+
+(define (serialize-git-section-header name value)
+  (format #f "[~a~a]\n" (uglify-field-name name)
+          (if value (format #f " \"~a\"" value) "")))
+
+(define serialize-git-section
+  (match-lambda
+    ((name options)
+     (cons
+      (serialize-git-section-header name #f)
+      (serialize-alist #f options)))
+    ((name value options)
+     (cons
+      (serialize-git-section-header name value)
+      (serialize-alist #f options)))))
+
+;; TODO: cover it with tests
+(define (serialize-git-config field-name val)
+  #~(string-append #$@(append-map serialize-git-section val)))
+
+(define (git-ignore? patterns)
+  (list-of-strings? patterns))
+(define (serialize-git-ignore field-name val)
+  (string-join val "\n" 'suffix))
+
+(define (git-attributes? attrs)
+  (list? attrs))
+(define (serialize-git-attributes field-name val)
+  (string-join
+   (map
+    (match-lambda
+      ((key . value) (format #f "~a\t~a" key value)))
+    val)
+   "\n"
+   'suffix))
+
+(define-configuration home-git-extension
+  (attributes
+   (git-attributes '())
+   "Alist of pattern attribute pairs for @file{git/attributes.}")
+  (ignore
+   (git-ignore '())
+   "List of patterns for @file{git/ignore.}")
+  (config
+   (git-config '())
+   "List of git sections.  The same format as in
+@code{home-git-configuration}."))
+
+(define-configuration home-git-configuration
+  (package
+   (package git)
+   "The Git package to use.")
+  (attributes
+   (git-attributes '())
+   "Alist of pattern attribute pairs for @file{git/attributes.}")
+  (attributes-extra-content
+   (text-config "")
+    "String or value of string-valued g-exps will be added to the end
+of the @file{git/attributes} file.")
+  (ignore
+   (git-ignore '())
+   "List of patterns for git/ignore.")
+  (ignore-extra-content
+   (text-config "")
+    "String or value of string-valued g-exps will be added to the end
+of the git/ignore file.")
+  (config
+   (git-config '())
+   "List of sections and corresponding options.  Something like this:
+
+@lisp
+`((sendmail
+   ((annotate . #t))))
+@end lisp
+
+will turn into this:
+
+@example
+[sendmail]
+        annotate = true
+@end example")
+  (config-extra-content
+   (text-config "")
+   "String or value of string-valued g-exps will be added to the end
+of the configuration file."))
+
+(define (add-git-configuration config)
+  (define (filter-fields fields)
+    (filter-configuration-fields home-git-configuration-fields fields))
+  `(("config/git/attributes"
+     ,(mixed-text-file
+       "git-attributes"
+       (serialize-configuration
+        config
+	(filter-fields '(attributes)))
+       (home-git-configuration-attributes-extra-content config)))
+    ("config/git/ignore"
+     ,(mixed-text-file
+       "git-ignore"
+       (serialize-configuration
+        config
+	(filter-fields '(ignore)))
+       (home-git-configuration-ignore-extra-content config)))
+    ("config/git/config"
+     ,(mixed-text-file
+	     "git-config"
+	     (serialize-configuration
+              config
+	      (filter-fields '(config)))
+	     (home-git-configuration-config-extra-content config)))))
+
+(define (add-git-packages config)
+  (list (home-git-configuration-package config)))
+
+(define (home-git-extensions original-config extension-configs)
+  (home-git-configuration
+   (inherit original-config)
+   (attributes
+    (append (home-git-configuration-attributes original-config)
+	    (append-map
+	     home-git-extension-attributes extension-configs)))
+   (ignore
+    (append (home-git-configuration-ignore original-config)
+	    (append-map
+	     home-git-extension-ignore extension-configs)))
+   (config
+    (append (home-git-configuration-config original-config)
+	    (append-map
+	     home-git-extension-config extension-configs)))))
+
+(define home-git-service-type
+  (service-type (name 'home-git)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        add-git-configuration)
+                       (service-extension
+                        home-profile-service-type
+                        add-git-packages)))
+		(compose identity)
+		(extend home-git-extensions)
+                (default-value (home-git-configuration))
+                (description "Install and configure Git.")))
+
+(define (generate-home-git-documentation)
+  (generate-documentation
+   `((home-git-configuration
+      ,home-git-configuration-fields))
+   'home-git-configuration))
+
+
+;;;
+;;; Mercurial.
+;;;
+;;; (home-hg-configuration
+;;;   (regexp-ignore '("^\\.pc/"))
+;;;   (glob-ignore '("*.elc" "*~"))
+;;;   (config
+;;;    '((commands
+;;;       ((commit.post-status . #t)))
+;;;      (ui
+;;;       ((username . "Alice Bobson <[email-masked]")))
+;;;      (defaults
+;;;        (log . "-v")))))
+;;;
+
+;; TODO: Add separate field for name and email?
+(define-configuration/no-serialization home-hg-configuration
+  (package
+    (package mercurial)
+    "The Mercurial package to use.")
+  (regexp-ignore
+   (list-of-strings '())
+   "List of regular expressions to ignore globally.  The default syntax
+is Python/Perl-style regular expression (see @command{man 5 hgignore}).
+
+The @code{*-ignore} fields are equivalent to adding @code{ui.ignore =
+/file/with/ignore/rules} in your @file{hgrc}.")
+  (glob-ignore
+   (list-of-strings '())
+   "List of globs to ignore globally.")
+  (rootglob-ignore
+   (list-of-strings '())
+   "List of @dfn{rootglobs} to ignore globally.")
+  (config
+   (ini-config '())
+   "List of list representing the contents of the @file{hgrc}
+configuration file.  The syntax is similar to that of the Git service.
+The key of a pair can be a symbol or string, and the value can be a
+boolean, string, symbol, number, gexp (@pxref{gexp,,,guix.info}), or a
+list of one the above.
+
+@lisp
+(config
+ `((commands
+    ((commit.post-status . #t)))
+   (graph
+    ((width . 4)))
+   (hooks
+    ((incoming.email . ,(local-file \"/path/to/email/hook\"))))))
+@end lisp
+
+will turn into this:
+
+@example
+[commands]
+    commit.post-status = True
+[graph]
+    width = 4
+[hooks]
+  incoming.email = /gnu/store/123...-email-hook
+@end example"))
+
+(define (serialize-hg-config config)
+  (define (serialize-boolean val)
+    (list (if val "True" "False")))
+
+  (define (serialize-list val)
+    (interpose (map serialize-val val) ", "))
+
+  (define (serialize-val val)
+    (cond
+     ((list? val) (serialize-list val))
+     ((boolean? val) (serialize-boolean val))
+     ((or (number? val) (symbol? val)) (list (maybe-object->string val)))
+     (else (list val))))
+
+  (define (serialize-field key val)
+    (let ((val (serialize-val val))
+          (key (symbol->string key)))
+      `(,key " = " ,@val "\n")))
+
+  (flatten (generic-serialize-ini-config
+            #:combine-ini interpose
+            #:combine-alist list
+            #:combine-section-alist cons
+            #:serialize-field serialize-field
+            #:fields config)))
+
+(define* (serialize-hg-ignores #:key regexp glob rootglob)
+  (define (add-ignore lst type)
+    (if (not (null? lst))
+        (string-append (format #f "syntax: ~a\n" type)
+                       (string-join lst "\n" 'suffix))
+        ""))
+
+  (string-join (map (cut add-ignore <> <>)
+                    (list regexp glob rootglob)
+                         '(regexp glob rootglob))
+               "\n"))
+
+(define (home-hg-files-service config)
+  (define rest cdr)
+
+  (define (compare-sections section1 section2)
+    (string<? (symbol->string (first section1))
+              (symbol->string (first section2))))
+
+  (define (fold-sections section1 section2)
+    (cond
+     ((equal? (first section1) (first section2))
+      (list (list (first section1)
+                  (append (second section1) (second section2)))))
+     (else
+      (list section1 section2))))
+
+  (define (merge-sections config)
+    (let ((sorted-config (sort config compare-sections)))
+      (fold (lambda (section acc)
+              (if (null? acc)
+                  (list section)
+                  (append (fold-sections section (first acc))
+                          (rest acc))))
+            '()
+            sorted-config)))
+
+  (let* ((ignores (serialize-hg-ignores
+                   #:regexp
+                   (home-hg-configuration-regexp-ignore config)
+                   #:glob
+                   (home-hg-configuration-glob-ignore config)
+                   #:rootglob
+                   (home-hg-configuration-rootglob-ignore config)))
+         (final-config (merge-sections
+                        (append (home-hg-configuration-config config)
+                                `((ui
+                                   ((ignore . ,(plain-file "hg-ignores"
+                                                           ignores)))))))))
+    `(("config/hg/hgrc"
+       ,(apply mixed-text-file
+               "hgrc"
+               (serialize-hg-config final-config))))))
+
+(define-configuration/no-serialization home-hg-extension
+  (regexp-ignore
+   (list-of-strings '())
+   "List of regular expressions to ignore globally.")
+  (glob-ignore
+   (list-of-strings '())
+   "List of glob expressions to ignore globally.")
+  (rootglob-ignore
+   (list-of-strings '())
+   "List of @dfn{rootglobs} to ignore globally.")
+  (config
+   (ini-config '())
+   "List of lists representing the contents of the @file{hgrc} file."))
+
+(define (home-hg-extensions original-config extension-configs)
+  (home-hg-configuration
+   (inherit original-config)
+   (regexp-ignore
+    (append (home-hg-configuration-regexp-ignore original-config)
+            (append-map
+             home-hg-extension-regexp-ignore extension-configs)))
+   (glob-ignore
+    (append (home-hg-configuration-glob-ignore original-config)
+            (append-map
+             home-hg-extension-glob-ignore extension-configs)))
+   (rootglob-ignore
+    (append (home-hg-configuration-rootglob-ignore original-config)
+            (append-map
+             home-hg-extension-rootglob-ignore extension-configs)))
+   (config
+    (append (home-hg-configuration-config original-config)
+            (append-map
+             home-hg-extension-config extension-configs)))))
+
+(define (home-hg-profile-service config)
+  (list (home-hg-configuration-package config)))
+
+(define home-hg-service-type
+  (service-type (name 'home-hg)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        home-hg-files-service)
+                       (service-extension
+                        home-profile-service-type
+                        home-hg-profile-service)))
+                (compose identity)
+                (extend home-hg-extensions)
+                (default-value (home-hg-configuration))
+                (description "\
+Install and configure the Mercurial version control system.")))
+
+(define (generate-home-hg-documentation)
+  (string-append
+   (generate-documentation
+    `((home-hg-configuration
+       ,home-hg-configuration-fields))
+    'home-hg-configuration)
+   "\n\n"
+   (generate-documentation
+    `((home-hg-extension
+       ,home-hg-extension-fields))
+    'home-hg-extension)))
diff --git a/gnu/local.mk b/gnu/local.mk
index d432829e2d..4ac1083158 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -79,7 +79,9 @@ GNU_SYSTEM_MODULES =				\
   %D%/home/services/fontutils.scm		\
   %D%/home/services/shells.scm			\
   %D%/home/services/shepherd.scm		\
+  %D%/home/services/state.scm			\
   %D%/home/services/mcron.scm			\
+  %D%/home/services/version-control.scm	\
   %D%/home/services/utils.scm			\
   %D%/home/services/xdg.scm			\
   %D%/image.scm					\
diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm
index 24e60d9d9d..8b4768a38a 100644
--- a/gnu/tests/rsync.scm
+++ b/gnu/tests/rsync.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Christopher Baines <[email-masked]>
 ;;; Copyright © 2018 Clément Lassieur <[email-masked]>
+;;; Copyright © 2021 Oleg Pykhalov <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,7 +30,13 @@ (define-module (gnu tests rsync)
   #:use-module (gnu services networking)
   #:use-module (guix gexp)
   #:use-module (guix store)
-  #:export (%test-rsync))
+  #:use-module (gnu home)
+  #:use-module (gnu services)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services state)
+  #:use-module (guix scripts home)
+  #:export (%test-rsync
+            %test-home-state-rsync))
 
 (define* (run-rsync-test rsync-os #:optional (rsync-port 873))
   "Run tests in %RSYNC-OS, which has rsync running and listening on
@@ -127,3 +134,152 @@ (define %test-rsync
    (name "rsync")
    (description "Connect to a running RSYNC server.")
    (value (run-rsync-test %rsync-os))))
+
+
+;;;
+;;; Home
+;;;
+
+(define* (run-home-state-rsync-test home-state-rsync-os #:optional (rsync-port 873))
+  "Run tests in %HOME-STATE-RSYNC-OS, which has rsync running and listening on
+PORT."
+  (define os
+    (marionette-operating-system
+     home-state-rsync-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings '())))
+
+  (define he
+    (home-environment
+     (services
+      (list
+       (service home-state-service-type
+                (list
+                 (state-rsync "/home/alice/test"
+                              (string-append "rsync://localhost:"
+                                             (number->string rsync-port)
+                                             "/files/input"))))))))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (srfi srfi-11)
+                       (srfi srfi-64)
+                       (gnu build marionette)
+                       (guix build utils))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "home-state-rsync")
+
+          ;; Wait for rsync to be up and running.
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+
+                ;; Make sure the 'rsync' command is found.
+                (setenv "PATH" "/run/current-system/profile/bin")
+
+                (start-service 'rsync))
+             marionette))
+
+          ;; Make sure the PID file is created.
+          (test-assert "PID file"
+            (marionette-eval
+             '(file-exists? "/var/run/rsyncd/rsyncd.pid")
+             marionette))
+
+          (test-assert "Test file copied to share"
+            (marionette-eval
+             '(begin
+                (call-with-output-file "/tmp/input"
+                  (lambda (port)
+                    (display "test-file-contents\n" port)))
+                (zero?
+                 (system* "rsync" "/tmp/input"
+                          (string-append "rsync://localhost:"
+                                         (number->string #$rsync-port)
+                                         "/files/input"))))
+             marionette))
+
+          ;; XXX: Create /run/user/1000 and /var/guix/profiles/per-user/alice
+          ;; directories.
+          (test-assert "profile and XDG_RUNTIME_DIR directories"
+            (marionette-eval
+             '(begin
+                (for-each (lambda (directory)
+                            (mkdir directory)
+                            (chown directory
+                                   (passwd:uid (getpw "alice"))
+                                   (group:gid (getpw "alice"))))
+                          '("/var/guix/profiles/per-user/alice"
+                            "/run/user"
+                            "/run/user/1000")))
+             marionette))
+
+          ;; Add /run/setuid-programs to $PATH so that the scripts
+          ;; can find 'env' and 'sudo'.
+          (marionette-eval
+           '(setenv "PATH"
+                    "/run/setuid-programs:/run/current-system/profile/bin")
+           marionette)
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(begin
+                (system* "sudo" "--user" "alice" "--login"
+                         "XDG_RUNTIME_DIR=/run/user/1000" "--" #$script))
+             marionette))
+
+          ;; Clone the repo.
+          (test-assert "herd init state"
+            (marionette-eval
+             '(begin
+                (invoke "sudo" "--user" "alice" "--login"
+                        "--" "herd" "init" "state"))
+             marionette))
+
+          (test-equal "Test file correctly received from share"
+            "test-file-contents"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (call-with-input-file "/home/alice/test"
+                  (lambda (port)
+                    (read-line port))))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "home-state-rsync-test"
+    (test
+     (switch-home-program he "/var/guix/profiles/per-user/alice/guix-home"))))
+
+(define* %home-state-rsync-os
+  ;; Return operating system under test.
+  (let ((base-os
+         (simple-operating-system
+          (service dhcp-client-service-type)
+          (service rsync-service-type))))
+    (operating-system
+      (inherit base-os)
+      (packages (cons* rsync
+                       (operating-system-packages base-os))))))
+
+(define %test-home-state-rsync
+  (system-test
+   (name "home-state-rsync")
+   (description "Connect to a running RSYNC server.")
+   (value (run-home-state-rsync-test %home-state-rsync-os))))
diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm
index a7cde1f163..9b461d3877 100644
--- a/gnu/tests/version-control.scm
+++ b/gnu/tests/version-control.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Oleg Pykhalov <[email-masked]>
+;;; Copyright © 2017, 2018, 2021 Oleg Pykhalov <[email-masked]>
 ;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2017, 2018 Clément Lassieur <[email-masked]>
 ;;; Copyright © 2018 Christopher Baines <[email-masked]>
@@ -36,10 +36,16 @@ (define-module (gnu tests version-control)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix modules)
+  #:use-module (gnu home)
+  #:use-module (gnu services)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services state)
+  #:use-module (guix scripts home)
   #:export (%test-cgit
             %test-git-http
             %test-gitolite
-            %test-gitile))
+            %test-gitile
+            %test-home-state-git))
 
 (define README-contents
   "Hello!  This is what goes inside the 'README' file.")
@@ -550,3 +556,133 @@ (define %test-gitile
    (name "gitile")
    (description "Connect to a running Gitile server.")
    (value (run-gitile-test))))
+
+
+;;;
+;;; Home
+;;;
+
+(define* (run-home-state-git-test home-state-git-os)
+  "Run tests in %HOME-STATE-GIT-OS, which has Guix home configuration with
+service for Git repository management."
+  (define os
+    (marionette-operating-system
+     home-state-git-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings '())))
+
+  (define he
+    (home-environment
+     (services
+      (list
+       (service home-state-service-type
+                (list (state-git "/home/alice/test"
+                                 "file:///srv/git/test")))))))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (guix build utils)
+                       (ice-9 popen)
+                       (ice-9 rdelim)
+                       (rnrs io ports)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "home-state-git")
+
+          ;; Make sure Git test repository is created.
+          (test-assert "Git test repository"
+            (marionette-eval
+             '(file-exists? "/srv/git/test")
+             marionette))
+
+          ;; XXX: Create /run/user/1000 and /var/guix/profiles/per-user/alice
+          ;; directories.
+          (test-assert "profile and XDG_RUNTIME_DIR directories"
+            (marionette-eval
+             '(begin
+                (for-each (lambda (directory)
+                            (mkdir directory)
+                            (chown directory
+                                   (passwd:uid (getpw "alice"))
+                                   (group:gid (getpw "alice"))))
+                          '("/var/guix/profiles/per-user/alice"
+                            "/run/user"
+                            "/run/user/1000")))
+             marionette))
+
+          ;; Add /run/setuid-programs to $PATH so that the scripts
+          ;; can find 'env' and 'sudo'.
+          (marionette-eval
+           '(setenv "PATH"
+                    "/run/setuid-programs:/run/current-system/profile/bin")
+           marionette)
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(begin
+                (system* "sudo" "--user" "alice" "--login"
+                         "XDG_RUNTIME_DIR=/run/user/1000" "--" #$script))
+             marionette))
+
+          ;; Clone the repo.
+          (test-assert "herd init state"
+            (marionette-eval
+             '(begin
+                (invoke "sudo" "--user" "alice" "--login"
+                        "--" "herd" "init" "state"))
+             marionette))
+
+          (test-equal "repo clonned"
+            '#$README-contents
+            (marionette-eval
+             '(begin
+                (call-with-input-file "/home/alice/test/README"
+                  get-string-all))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "home-state-git-test"
+    (test
+     (switch-home-program he "/var/guix/profiles/per-user/alice/guix-home"))))
+
+(define* %home-state-git-os
+  ;; Return operating system under test.
+  (let ((base-os
+         (simple-operating-system
+          (service dhcp-client-service-type)
+          %test-repository-service)))
+    (operating-system
+      (inherit base-os)
+
+      ;; Set a user account; the test needs it.
+      (users (cons (user-account
+                    (name "alice")
+                    (group "users")
+                    (uid 1000)
+                    (home-directory "/home/alice"))
+                   %base-user-accounts))
+
+      (packages (cons* git
+                       (operating-system-packages base-os))))))
+
+(define %test-home-state-git
+  (system-test
+   (name "home-state-git")
+   (description "Manage Git repository via Guix home.")
+   (value (run-home-state-git-test %home-state-git-os))))
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 55e7b436c1..0136dd3afc 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -25,9 +25,12 @@ (define-module (guix scripts home)
   #:use-module (gnu packages)
   #:use-module (gnu home)
   #:use-module (gnu home services)
+  #:use-module ((guix self) #:select (make-config.scm))
+  #:use-module (gnu packages gnupg)
   #:use-module (guix channels)
   #:use-module (guix derivations)
   #:use-module (guix ui)
+  #:use-module (guix modules)
   #:use-module (guix grafts)
   #:use-module (guix packages)
   #:use-module (guix profiles)
@@ -47,7 +50,8 @@ (define-module (guix scripts home)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
-  #:export (guix-home))
+  #:export (guix-home
+            switch-home-program))
 
 
 ;;;
@@ -139,11 +143,94 @@ (define %default-options
     (verbosity . 3)
     (debug . 0)))
 
+
+;;;
+;;; Profile creation.
+;;;
+
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix rest ...) #t)
+    (('gnu rest ...) #t)
+    (_ #f)))
+
+(define* (switch-home-program he-out-path #:optional (profile %guix-home))
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of HOME, switch to it
+atomically, and run HOME's activation script."
+  (program-file
+   "switch-to-home.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules `(,@(source-module-closure
+                                 '((guix profiles)
+                                   (guix utils))
+                                 #:select? not-config?)
+                              ((guix config) => ,(make-config.scm)))
+       #~(begin
+           (use-modules (guix config)
+                        (guix profiles)
+                        (guix utils))
+           (let* ((number (generation-number #$profile))
+                  (generation (generation-file-name
+                               #$profile (+ 1 number))))
+             (use-modules (ice-9 rdelim)
+                          (ice-9 popen))
+             (with-output-to-file "/tmp/out.txt"
+               (lambda ()
+                 (display "he-out-path:\n")
+                 (display #$he-out-path)
+                 (display "\nprofile:\n")
+                 (display #$profile)
+                 (display "\ngeneration:\n")
+                 (display generation)
+                 (let* ((port
+                         (open-pipe (format #f "/run/current-system/profile/bin/ls -laR ~a" #$he-out-path)
+                                           OPEN_READ))
+                        (output (read-string port)))
+                   (close-port port)
+                   (pk (string-trim-right output #\newline)))))
+             (switch-symlinks generation #$he-out-path)
+             (switch-symlinks #$profile generation)
+             (setenv "GUIX_NEW_HOME" #$he-out-path)
+             (primitive-load (string-append #$he-out-path "/activate"))
+             (setenv "GUIX_NEW_HOME" #f)))))))
+
+(define* (switch-to-home eval he-out-path)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of HOME, switch to
+it atomically, and run HOME's activation script."
+  (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+            (primitive-load #$(switch-home-program he-out-path)))))
+
 
 ;;;
 ;;; Actions.
 ;;;
 
+(define-syntax-rule (save-load-path-excursion body ...)
+  "Save the current values of '%load-path' and '%load-compiled-path', run
+BODY..., and restore them."
+  (let ((path %load-path)
+        (cpath %load-compiled-path))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (set! %load-path path)
+        (set! %load-compiled-path cpath)))))
+
+(define (local-eval exp)
+  "Evaluate EXP, a G-Expression, in-place."
+  (mlet* %store-monad ((lowered (lower-gexp exp))
+                       (_ (built-derivations (lowered-gexp-inputs lowered))))
+    (save-load-path-excursion
+     (set! %load-path (lowered-gexp-load-path lowered))
+     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+     (return (primitive-eval (lowered-gexp-sexp lowered))))))
+
 (define* (perform-action action he
                          #:key
                          dry-run?
@@ -170,15 +257,8 @@ (define println
 
           (case action
             ((reconfigure)
-             (let* ((number (generation-number %guix-home))
-                    (generation (generation-file-name
-                                 %guix-home (+ 1 number))))
-
-               (switch-symlinks generation he-out-path)
-               (switch-symlinks %guix-home generation)
-               (setenv "GUIX_NEW_HOME" he-out-path)
-               (primitive-load (string-append he-out-path "/activate"))
-               (setenv "GUIX_NEW_HOME" #f)
+             (mbegin %store-monad
+               (switch-to-home local-eval he-out-path)
                (return he-out-path)))
             (else
              (newline)
-- 
2.33.1