* [bug#51359] [PATCH 1/1] home: services: Add state services.
2021-10-23 18:04 [bug#51359] [PATCH 0/1] home-state-service-type and tests suite Oleg Pykhalov
@ 2021-10-23 18:06 ` Oleg Pykhalov
2021-10-30 11:10 ` [bug#51359] [PATCH 0/1] home-state-service-type and tests suite Xinglu Chen
2022-06-08 16:10 ` Andrew Tropin
2 siblings, 0 replies; 6+ messages in thread
From: Oleg Pykhalov @ 2021-10-23 18:06 UTC (permalink / raw)
To: 51359; +Cc: Oleg Pykhalov
* 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)))))))
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; Mercurial.
+;;;
+;;; (home-hg-configuration
+;;; (regexp-ignore '("^\\.pc/"))
+;;; (glob-ignore '("*.elc" "*~"))
+;;; (config
+;;; '((commands
+;;; ((commit.post-status . #t)))
+;;; (ui
+;;; ((username . "Alice Bobson <charlie@example.org")))
+;;; (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@cbaines.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; 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))))
+
+\f
+;;;
+;;; 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@gmail.com>
+;;; Copyright © 2017, 2018, 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
@@ -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))))
+
+\f
+;;;
+;;; 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))
\f
;;;
@@ -139,11 +143,94 @@ (define %default-options
(verbosity . 3)
(debug . 0)))
+\f
+;;;
+;;; 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)))))
+
\f
;;;
;;; 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
^ permalink raw reply related [flat|nested] 6+ messages in thread