From b462f68c7f74d44cf409c447faabc25c955acd56 Mon Sep 17 00:00:00 2001 From: Jakub Dlugosz Date: Fri, 31 Oct 2025 12:56:16 +0100 Subject: Fix (gnu home-services state) and add feature-state --- src/gnu/home-services/state.scm | 223 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 223 insertions(+) create mode 100644 src/gnu/home-services/state.scm (limited to 'src/gnu/home-services/state.scm') 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."))) -- cgit v1.2.3