GNU logs - #51359, boring messages


Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: [bug#51359] [PATCH 0/1] home-state-service-type and tests suite
Resent-From: Oleg Pykhalov <go.wigust@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Sat, 23 Oct 2021 18:06:02 +0000
Resent-Message-ID: <handler.51359.B.163501231420857 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: report 51359
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: patch
To: 51359 <at> debbugs.gnu.org
Cc: Oleg Pykhalov <go.wigust@HIDDEN>
X-Debbugs-Original-To: guix-patches@HIDDEN
Received: via spool by submit <at> debbugs.gnu.org id=B.163501231420857
          (code B ref -1); Sat, 23 Oct 2021 18:06:02 +0000
Received: (at submit) by debbugs.gnu.org; 23 Oct 2021 18:05:14 +0000
Received: from localhost ([127.0.0.1]:37178 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1meLOL-0005QJ-J1
	for submit <at> debbugs.gnu.org; Sat, 23 Oct 2021 14:05:13 -0400
Received: from lists.gnu.org ([209.51.188.17]:60354)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <go.wigust@HIDDEN>) id 1meLOJ-0005Q8-Bh
 for submit <at> debbugs.gnu.org; Sat, 23 Oct 2021 14:05:13 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10]:54396)
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <go.wigust@HIDDEN>)
 id 1meLOH-00033f-UE
 for guix-patches@HIDDEN; Sat, 23 Oct 2021 14:05:11 -0400
Received: from mail-lf1-x135.google.com ([2a00:1450:4864:20::135]:41839)
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128)
 (Exim 4.90_1) (envelope-from <go.wigust@HIDDEN>)
 id 1meLOF-00026W-5x
 for guix-patches@HIDDEN; Sat, 23 Oct 2021 14:05:09 -0400
Received: by mail-lf1-x135.google.com with SMTP id u21so3291430lff.8
 for <guix-patches@HIDDEN>; Sat, 23 Oct 2021 11:05:05 -0700 (PDT)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112;
 h=from:to:cc:subject:date:message-id:mime-version
 :content-transfer-encoding;
 bh=7AeuwcPXmQBf2FKTRYvP4CiVWd25EqYOQhaqCUftjgQ=;
 b=Kya335JOCj0xt2ko9Wb1C3Z461D03zZf18d7ttTSVzo09Ys7VzSiRbl9TYEhtHyoj2
 R6GU3lm1Kk3GB/AimjqroXyhy7eaxtTAegtxPGV5XkU3r775gbYyhCd7BUKhP/KIATbJ
 jIhUit5H52vqdHK0eOEXCgyHPUZeQjkHlB/HpGcbwv1DaQ8C6KD9Ed9FkOoIJR23OXcx
 kKqCKeDYL+glTm/NavYYStnB9AWF0GZU5aY+hC+s97MCopXbtqmHP0YATgF2sYUD/SU3
 WykjXBAFSKcaR65/D+wZTA2REru0zZaFw3p+rPRL/26Ng4E3TVCuT6jnoj0x1qQlg9aW
 g6gw==
X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=1e100.net; s=20210112;
 h=x-gm-message-state:from:to:cc:subject:date:message-id:mime-version
 :content-transfer-encoding;
 bh=7AeuwcPXmQBf2FKTRYvP4CiVWd25EqYOQhaqCUftjgQ=;
 b=hu1kn0ivbKtsdR7qKF+HAWgzqAMF+erZ4hGWaHO3Va97LsSC/d8PV8zJCr3eXlbxaU
 o+c+ipHjttHmTcvV5uugP3rFPHTUSx7cpQjPzjLAWzW2K59d1kSYb/PpjuV2GSMO1rHx
 /w1VI4glFX5vYy2WoOI0TqwxFWo+Eg9kidnpqXQeGJFgAGlHmlUeWFC6gx+3ycvPxwG/
 jVz3QnAjexP0/RK/A7TOiRuAKmZuZruerHeFIUtzgIAqk2fbqcT2h44jb21NKeQPdhnA
 /Z5Bmgtyy8g4wC0t/g1UB7OTSY9w9l84oG/JWmRbtIDQTaLya6Ra3pq07xWTkmwyKy12
 PVug==
X-Gm-Message-State: AOAM533Og8XtNyBLf2llR8pBROxh439+85irJ6S/y760ZCz4lxfK9h15
 TL4EgX/XzqiIxkscnlBt/jVAAVB8VNI=
X-Google-Smtp-Source: ABdhPJzXjV8+PI8RZjrjRvqQ9pjGxSIoD4IXab3tIW3jvuA3dJkGPhIZ7pcWVl5rspCLnzU6in39rg==
X-Received: by 2002:a05:6512:2115:: with SMTP id
 q21mr7015235lfr.659.1635012304366; 
 Sat, 23 Oct 2021 11:05:04 -0700 (PDT)
Received: from localhost.localdomain ([88.201.161.72])
 by smtp.gmail.com with ESMTPSA id y26sm860942lja.91.2021.10.23.11.05.03
 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256);
 Sat, 23 Oct 2021 11:05:04 -0700 (PDT)
From: Oleg Pykhalov <go.wigust@HIDDEN>
Date: Sat, 23 Oct 2021 21:04:46 +0300
Message-Id: <20211023180446.3362-1-go.wigust@HIDDEN>
X-Mailer: git-send-email 2.33.1
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
Received-SPF: pass client-ip=2a00:1450:4864:20::135;
 envelope-from=go.wigust@HIDDEN; helo=mail-lf1-x135.google.com
X-Spam_score_int: -20
X-Spam_score: -2.1
X-Spam_bar: --
X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
 DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001,
 RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001,
 SPF_PASS=-0.001 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-Spam-Score: -1.3 (-)
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -2.3 (--)

Hi Guix,

This patch adds support for home-state-service-type which copied from the rde
project [1].  The introduction to home state services in documentation is
copied from discussion [2].

Tests passed:

    make check-system TESTS="home-state-git"
    make check-system TESTS="home-state-rsync"

[1] https://github.com/abcdw/rde/
[2] https://lists.sr.ht/~abcdw/rde-devel/%3C87pmzze9nn.fsf%40trop.in%3E#%3CCABrWRW1Fq-8mS=MbWJedUpayj1vFg-YE0oNF3zVTYWBMnp29Lg@HIDDEN%3E

Oleg Pykhalov (1):
  home: services: Add state services.

 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

-- 
2.33.1





Message sent:


Content-Disposition: inline
Content-Transfer-Encoding: quoted-printable
MIME-Version: 1.0
X-Mailer: MIME-tools 5.505 (Entity 5.505)
Content-Type: text/plain; charset=utf-8
X-Loop: help-debbugs@HIDDEN
From: help-debbugs@HIDDEN (GNU bug Tracking System)
To: Oleg Pykhalov <go.wigust@HIDDEN>
Subject: bug#51359: Acknowledgement ([PATCH 0/1] home-state-service-type
 and tests suite)
Message-ID: <handler.51359.B.163501231420857.ack <at> debbugs.gnu.org>
References: <20211023180446.3362-1-go.wigust@HIDDEN>
X-Gnu-PR-Message: ack 51359
X-Gnu-PR-Package: guix-patches
X-Gnu-PR-Keywords: patch
Reply-To: 51359 <at> debbugs.gnu.org
Date: Sat, 23 Oct 2021 18:06:02 +0000

Thank you for filing a new bug report with debbugs.gnu.org.

This is an automatically generated reply to let you know your message
has been received.

Your message is being forwarded to the package maintainers and other
interested parties for their attention; they will reply in due course.

Your message has been sent to the package maintainer(s):
 guix-patches@HIDDEN

If you wish to submit further information on this problem, please
send it to 51359 <at> debbugs.gnu.org.

Please do not send mail to help-debbugs@HIDDEN unless you wish
to report a problem with the Bug-tracking system.

--=20
51359: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3D51359
GNU Bug Tracking System
Contact help-debbugs@HIDDEN with problems


Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: [bug#51359] [PATCH 1/1] home: services: Add state services.
References: <20211023180446.3362-1-go.wigust@HIDDEN>
In-Reply-To: <20211023180446.3362-1-go.wigust@HIDDEN>
Resent-From: Oleg Pykhalov <go.wigust@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Sat, 23 Oct 2021 18:08:01 +0000
Resent-Message-ID: <handler.51359.B51359.163501244221095 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 51359
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: patch
To: 51359 <at> debbugs.gnu.org
Cc: Oleg Pykhalov <go.wigust@HIDDEN>
Received: via spool by 51359-submit <at> debbugs.gnu.org id=B51359.163501244221095
          (code B ref 51359); Sat, 23 Oct 2021 18:08:01 +0000
Received: (at 51359) by debbugs.gnu.org; 23 Oct 2021 18:07:22 +0000
Received: from localhost ([127.0.0.1]:37183 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1meLQL-0005U3-4t
	for submit <at> debbugs.gnu.org; Sat, 23 Oct 2021 14:07:22 -0400
Received: from mail-lf1-f52.google.com ([209.85.167.52]:38809)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <go.wigust@HIDDEN>) id 1meLQH-0005Tn-Dx
 for 51359 <at> debbugs.gnu.org; Sat, 23 Oct 2021 14:07:15 -0400
Received: by mail-lf1-f52.google.com with SMTP id x27so182432lfu.5
 for <51359 <at> debbugs.gnu.org>; Sat, 23 Oct 2021 11:07:13 -0700 (PDT)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112;
 h=from:to:cc:subject:date:message-id:mime-version
 :content-transfer-encoding;
 bh=p1N5eGIcIAPDesvroNuxwf3eg/vywLrFLoTRv2UJ7yU=;
 b=b52XcmxWzhPt7CJTqxavolhFBhSOVf0wE5c7XhsqK2LD5IGdsZsuDwN0PdwtPudVrP
 ho/4CG3lfdBxueIf1J/zpUSzi5kiysN9AnRlMdPhCO8FLF8vWjMc1nayZni/vbdmbY6Z
 PZNB2MKKgJYb5i00KoUN3xi29dCbxaSlarT4EHOV37HYZnKBRlaCVgbXVZ36aLbBrxmp
 LyfHo/856WM4dv9fJTJ3bXOHziS8s45vBQB/5CzX3ACah9FM1iL33vdADCTfYtxSgR9K
 O/fKBWPed1njITNmu52FwDhDLah6OavRaPTokwKuQK3f8QVNnomY88BgfKcYAVeNaioI
 4zdA==
X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=1e100.net; s=20210112;
 h=x-gm-message-state:from:to:cc:subject:date:message-id:mime-version
 :content-transfer-encoding;
 bh=p1N5eGIcIAPDesvroNuxwf3eg/vywLrFLoTRv2UJ7yU=;
 b=T/k8tg1uv1fI2XG4s1hcijsA8zIyQ0UR4YZrIRaQManPENSAP9F+yTUglpgamV6pwS
 YGn+SpSjcyvPL0X/TDw+Zf3kiMVJOZL0ICJW9mkzhj7S8xzSOZ3UNtZegFdHxhuBPLmD
 elJtpCYfhf8olxt7BHAUVuhqrTTuL0u8dwH7PKHTm0fIL5XtUjKm/uMdN2SSILlSssTd
 WaTUZe4+FoCsMY0HFhS+XsyyD9BKgXxwnft+xKTZ9kqlRpx4JbMP87uRn+4tf4AAcWHq
 RIUtQpBpnDLaMatXiXhg7/54XtZPMloGuWgsmqtosLzmv239e1hQp5H78eZW0jYyHuHD
 i1WA==
X-Gm-Message-State: AOAM531sG7kahJ5vVNqaU9tkrzBD1FpAGiUkyW7IGrrS5UoOcowRmsbC
 nRdZ9IFRNdKJTaO44SzI0bb3VehV2GI=
X-Google-Smtp-Source: ABdhPJzy+6MKwAK58Y0RB+7ASlzo3Ea0t7MV0UqsMab6nklUeSp4KNcOHXegjisrvWTIS/WVKt8f2Q==
X-Received: by 2002:a05:6512:314f:: with SMTP id
 s15mr6751877lfi.60.1635012425995; 
 Sat, 23 Oct 2021 11:07:05 -0700 (PDT)
Received: from localhost.localdomain ([88.201.161.72])
 by smtp.gmail.com with ESMTPSA id j8sm794171lfe.33.2021.10.23.11.07.05
 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256);
 Sat, 23 Oct 2021 11:07:05 -0700 (PDT)
From: Oleg Pykhalov <go.wigust@HIDDEN>
Date: Sat, 23 Oct 2021 21:06:54 +0300
Message-Id: <20211023180654.3760-1-go.wigust@HIDDEN>
X-Mailer: git-send-email 2.33.1
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Spam-Score: 0.0 (/)
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

* 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 <charlie@HIDDEN")))
+;;;      (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 <mail@HIDDEN>
 ;;; Copyright © 2018 Clément Lassieur <clement@HIDDEN>
+;;; Copyright © 2021 Oleg Pykhalov <go.wigust@HIDDEN>
 ;;;
 ;;; 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 <go.wigust@HIDDEN>
+;;; Copyright © 2017, 2018, 2021 Oleg Pykhalov <go.wigust@HIDDEN>
 ;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@HIDDEN>
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@HIDDEN>
 ;;; Copyright © 2018 Christopher Baines <mail@HIDDEN>
@@ -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






Last modified: Sat, 23 Oct 2021 18:15:01 UTC

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997 nCipher Corporation Ltd, 1994-97 Ian Jackson.