Toggle diff (550 lines)
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
