1 files changed, 223 insertions, 0 deletions
diff --git a/src/gnu/home-services/state.scm b/src/gnu/home-services/state.scm
new file mode 100644
index 0000000..aee9942
--- /dev/null
+++ b/src/gnu/home-services/state.scm
@@ -0,0 +1,223 @@
+(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 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))
+(use-modules (gnu packages version-control))
+(define* (state-hg path remote #:key (config #f))
+  (state-generic
+   path
+   #:init-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (perform-service-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 (perform-service-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))))
+(use-modules (gnu packages rsync))
+(define* (state-rsync path remote)
+  (state-generic
+   path
+   #:init-gexp
+   #~(lambda* (_ self)
+       (let* ((meta (perform-service-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 (perform-service-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 %service-get-gexp
+  #~(lambda (x)
+      (car
+       (filter
+        (lambda (y) (eq? (car (service-provision y)) x))
+        ((@@ (shepherd service) service-list))))))
+(define* (state-generic
+          path
+          #:key
+          (init-gexp
+           #~(lambda* (_ self)
+               (let ((path (assoc-ref (perform-service-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 (perform-service-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 (perform-service-action (#$%service-get-gexp '#$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 #~(lambda* (#:rest rest)
+                               (#$init-gexp rest (#$%service-get-gexp '#$self)))))
+               (shepherd-action
+                (name 'metadata)
+                (documentation "Returns metadata related to the state.")
+                (procedure #~(lambda* _
+                               (append
+                                `((path . #$path)
+                                  (self . ,(#$%service-get-gexp '#$self)))
+                                '#$additional-metadata))))
+               (shepherd-action
+                (name 'sync)
+                (documentation "Sync the state.")
+                (procedure #~(lambda* (#:rest rest)
+                               (#$sync-gexp rest (#$%service-get-gexp '#$self)))))
+               (shepherd-action
+                (name 'init)
+                (documentation "Generic initialize.")
+                (procedure #~(lambda* (#:rest rest)
+                               (if (perform-service-action (#$%service-get-gexp '#$self) 'state-exists?)
+                                   (format #t "~a already initialized.\n" '#$self)
+                                   (begin
+                                     (perform-service-action (#$%service-get-gexp '#$self) 'unchecked-init (#$%service-get-gexp '#$self))
+                                     (start-service (#$%service-get-gexp '#$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)
+                         (let ((name (#$%service-get-gexp name)))
+                          (when (perform-service-action name 'state-exists?)
+                            (start-service name))))
+                       '#$service-names)))
+       (actions (list
+                 (shepherd-action
+                  (name 'sync)
+                  (documentation
+                   "Sync all the state. Highly dependent on state type.")
+                  (procedure
+                   #~(lambda _
+                       (map (lambda (name)
+                              (let ((name (#$%service-get-gexp name)))
+                               (when (assoc-ref (perform-service-action name 'metadata)
+                                                'general-sync?)
+                                 (perform-service-action name 'sync name))))
+                            '#$service-names))))
+                 (shepherd-action
+                  (name 'init)
+                  (documentation "Initialize all the state.")
+                  (procedure #~(lambda _
+                                 (map (lambda (name)
+                                        (let ((name (#$%service-get-gexp name)))
+                                         (when (not (perform-service-action name 'state-exists?))
+                                           (perform-service-action name 'init)
+                                           (start-service 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/src/gnu/home-services/state.scm b/src/gnu/home-services/state.scm new file mode 100644 index 0000000..aee9942 --- /dev/null +++ b/src/gnu/home-services/state.scm
@@ -0,0 +1,223 @@
	1	(define-module (gnu home-services state)
	2	#:use-module (srfi srfi-1)
	3	#:use-module (ice-9 match)
	4	#:use-module (gnu home services)
	5	#:use-module (gnu home-services-utils)
	6	#:use-module (gnu home services shepherd)
	7	#:use-module (gnu home-services version-control)
	8	#:use-module (gnu services shepherd)
	9	#:use-module (gnu services configuration)
	10	#:use-module (gnu packages ssh)
	11	#:use-module (guix packages)
	12	#:use-module (guix gexp)
	13	#:use-module (guix monads)
	14	#:use-module (guix modules)
	15	#:use-module (guix records)
	16
	17	#:export (home-state-service-type
	18	state-generic
	19	state-git
	20	state-hg
	21	state-rsync))
	22
	23	(use-modules (gnu packages version-control))
	24	(define* (state-hg path remote #:key (config #f))
	25	(state-generic
	26	path
	27	#:init-gexp
	28	#~(lambda* (_ self)
	29	(let* ((meta (perform-service-action self 'metadata))
	30	(path (assoc-ref meta 'path))
	31	(remote (assoc-ref meta 'remote)))
	32	(format #t "Initializing ~a.\n" self)
	33	(let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
	34	#$(file-append mercurial "/bin/hg") "clone" remote path)))
	35	(waitpid WAIT_ANY)
	36	(display ((@ (ice-9 rdelim) read-delimited) "" port))
	37	(close-port port))
	38
	39	(when '#$config
	40	(call-with-output-file (string-append path "/.hg/hgrc")
	41	(lambda (port) (display (string-append
	42	#$@(serialize-hg-config config)) port))))))
	43	#:additional-metadata `((remote . ,remote)
	44	(general-sync? . #f))))
	45
	46	(define* (state-git path remote #:key (config #f))
	47	(state-generic
	48	path
	49	#:init-gexp
	50	#~(lambda* (_ self)
	51	(let* ((meta (perform-service-action self 'metadata))
	52	(path (assoc-ref meta 'path))
	53	(remote (assoc-ref meta 'remote)))
	54	(format #t "Initializing ~a.\n" self)
	55	;; TODO: revisit git clone implementation
	56	;; FIXME: Hang up shepherd if username/password asked
	57	(let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
	58	#$(file-append git "/bin/git") "clone" remote path)))
	59	(waitpid WAIT_ANY)
	60	(display ((@ (ice-9 rdelim) read-delimited) "" port))
	61	(close-port port))
	62
	63	(when #$config
	64	(call-with-output-file (string-append path "/.git/config")
	65	(lambda (port) (display #$config port))))))
	66	#:additional-metadata `((remote . ,remote)
	67	(general-sync? . #f))))
	68
	69	(use-modules (gnu packages rsync))
	70	(define* (state-rsync path remote)
	71	(state-generic
	72	path
	73	#:init-gexp
	74	#~(lambda* (_ self)
	75	(let* ((meta (perform-service-action self 'metadata))
	76	(path (assoc-ref meta 'path))
	77	(remote (assoc-ref meta 'remote)))
	78	(format #t "Initializing ~a.\n" self)
	79	;; TODO: revisit git clone implementation
	80	(let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
	81	#$(file-append rsync "/bin/rsync") "-aP" remote path)))
	82	(waitpid WAIT_ANY)
	83	(display ((@ (ice-9 rdelim) read-delimited) "" port))
	84	(close-port port))))
	85	#:sync-gexp
	86	#~(lambda* (_ self)
	87	(let* ((meta (perform-service-action self 'metadata))
	88	(path (assoc-ref meta 'path))
	89	(remote (assoc-ref meta 'remote)))
	90	(format #t "Synchronizing ~a.\n" self)
	91	(let* ((port ((@@ (guix build utils) open-pipe-with-stderr)
	92	#$(file-append rsync "/bin/rsync") "-aP" path remote)))
	93	(waitpid WAIT_ANY)
	94	(display ((@ (ice-9 rdelim) read-delimited) "" port))
	95	(close-port port))))
	96	#:additional-metadata `((remote . ,remote)
	97	(general-sync? . #t))))
	98
	99	(define %service-get-gexp
	100	#~(lambda (x)
	101	(car
	102	(filter
	103	(lambda (y) (eq? (car (service-provision y)) x))
	104	((@@ (shepherd service) service-list))))))
	105
	106	(define* (state-generic
	107	path
	108	#:key
	109	(init-gexp
	110	#~(lambda* (_ self)
	111	(let ((path (assoc-ref (perform-service-action self 'metadata) 'path)))
	112	(format #t "Initializing ~a.\n" self)
	113	(format #t "Creating ~a directory..." path)
	114	(mkdir-p path)
	115	(display " done\n"))))
	116	(sync-gexp
	117	#~(lambda* (_ self)
	118	(let ((path (assoc-ref (perform-service-action self 'metadata) 'path)))
	119	(format #t "Synchronizing ~a.\n" self)
	120	(format #t "Nothing to synchronize.\n"))))
	121	(additional-metadata '((general-sync? . #f))))
	122	"A function which returns a shepherd-service with all required
	123	actions for state management, should be used as a basis for other
	124	state related items like git-state, rsync-state, etc."
	125	(let ((self (string->symbol
	126	(format #f "state-~a" path))))
	127	(shepherd-service
	128	(documentation (format #f "Managing state at ~a." path))
	129	(provision (list self))
	130	(auto-start? #f)
	131	(start #~(lambda ()
	132	(if (perform-service-action (#$%service-get-gexp '#$self) 'state-exists?)
	133	#t
	134	(begin
	135	(format #t "~a is not initilized yet." '#$self)
	136	#f))))
	137	(actions (list
	138	(shepherd-action
	139	(name 'state-exists?)
	140	(documentation "Check if state file/directory exists.")
	141	(procedure #~(lambda* (#:rest rest)
	142	(file-exists? #$path))))
	143	(shepherd-action
	144	(name 'unchecked-init)
	145	(documentation "Do not use this action directly.")
	146	(procedure #~(lambda* (#:rest rest)
	147	(#$init-gexp rest (#$%service-get-gexp '#$self)))))
	148	(shepherd-action
	149	(name 'metadata)
	150	(documentation "Returns metadata related to the state.")
	151	(procedure #~(lambda* _
	152	(append
	153	`((path . #$path)
	154	(self . ,(#$%service-get-gexp '#$self)))
	155	'#$additional-metadata))))
	156	(shepherd-action
	157	(name 'sync)
	158	(documentation "Sync the state.")
	159	(procedure #~(lambda* (#:rest rest)
	160	(#$sync-gexp rest (#$%service-get-gexp '#$self)))))
	161	(shepherd-action
	162	(name 'init)
	163	(documentation "Generic initialize.")
	164	(procedure #~(lambda* (#:rest rest)
	165	(if (perform-service-action (#$%service-get-gexp '#$self) 'state-exists?)
	166	(format #t "~a already initialized.\n" '#$self)
	167	(begin
	168	(perform-service-action (#$%service-get-gexp '#$self) 'unchecked-init (#$%service-get-gexp '#$self))
	169	(start-service (#$%service-get-gexp '#$self))))))))))))
	170
	171	(define (add-shepherd-services services)
	172	(let* ((service-names
	173	(map
	174	(lambda (service) (car (shepherd-service-provision service)))
	175	services)))
	176	(append
	177	services
	178	(list
	179	(shepherd-service
	180	(documentation "Init, update and maybe destroy state.")
	181	(provision '(state))
	182	(auto-start? #t)
	183	(start #~(lambda ()
	184	(map (lambda (name)
	185	(let ((name (#$%service-get-gexp name)))
	186	(when (perform-service-action name 'state-exists?)
	187	(start-service name))))
	188	'#$service-names)))
	189	(actions (list
	190	(shepherd-action
	191	(name 'sync)
	192	(documentation
	193	"Sync all the state. Highly dependent on state type.")
	194	(procedure
	195	#~(lambda _
	196	(map (lambda (name)
	197	(let ((name (#$%service-get-gexp name)))
	198	(when (assoc-ref (perform-service-action name 'metadata)
	199	'general-sync?)
	200	(perform-service-action name 'sync name))))
	201	'#$service-names))))
	202	(shepherd-action
	203	(name 'init)
	204	(documentation "Initialize all the state.")
	205	(procedure #~(lambda _
	206	(map (lambda (name)
	207	(let ((name (#$%service-get-gexp name)))
	208	(when (not (perform-service-action name 'state-exists?))
	209	(perform-service-action name 'init)
	210	(start-service name))))
	211	'#$service-names)))))))))))
	212
	213
	214	(define home-state-service-type
	215	(service-type (name 'home-state)
	216	(extensions
	217	(list (service-extension
	218	home-shepherd-service-type
	219	add-shepherd-services)))
	220	(default-value '())
	221	(compose concatenate)
	222	(extend append)
	223	(description "A toolset for initializing state.")))