~abcdw/rde-devel

Add ‘run-on-change’ service v1 APPLIED

This patchseries adds a ‘run-on-change’ service.  This is useful for
running arbitrary commands that make a program reload/recompile its
configuration.

The ‘run-on-change’ service extends the
‘run-on-reconfigure’ service, and it uses the cmp(1) command to compare
two files byte by byte.  It works by comparing the files in
~/.guix-home-environment/files with the ones in
/var/guix/profiles/per-user/yoctocell/guix-home-environment-N-link/files
for the previous generation, so only files managed by Guix Home will be
affected.

The second patch makes use of the ‘run-on-change’ service by running
‘xrdb -load FILE’ when the Xresources config has changed.


Xinglu Chen (2):
  gnu: home-services: Add 'run-on-change' service.
  gnu: home-services: xorg: Make Xresources extend run-on-change
    service.

 gnu/home-services.scm      | 122 ++++++++++++++++++++++++++++++++++++-
 gnu/home-services/xorg.scm |  14 ++++-
 2 files changed, 134 insertions(+), 2 deletions(-)


base-commit: 927bb624d8153f0271ac6b563afe6f931017e369
-- 
2.31.1
Very cool service idea! Thank you)
> +(define (on-change-script-entry gexps)
> +  #~(begin #$gexps))
Seems unecessary.
> +(define (compute-on-change-script _ gexps)
s/script/gexp/
> +      (define (init lst)
init can be confusing in some contexts, maybe butlast will work here?
> +      ;; TODO: Make upstream move it to (guix utils)?
or (guix build utils)
> +          (map (lambda (pair) (cdr pair))
(map cdr
> +                            (string-append previous-generation
Used before it defined, breaks the flow, complicates reading of the
code.
> +            (lambda _
> +              (unless (file-exists? old-file)
> +                (throw 'error))
Not a good idea to control the flow of the program with exceptions.
> +              (let* ((pipe (open-pipe* OPEN_READ "cmp" old-file new-file))
Full path to cmp is preffered. #$(file-append diffutils "/bin/cmp")
> +          ;; /var/guix/profiles/per-user/USER/guix-home-environment-$(N-1)-link
It can be not true if we switching generation.  Also, I find
on-reconfigure to be a missleading script name, because in reality it
should be on-switch script, or activation, or something like that.
> +          (map (match-lambda
> +                 ((old new) (different-files old new)))
> +               (zip
No need to zip here, map can accept few lists.
> +                 (list (service-extension
> +                        home-run-on-reconfigure-service-type
> +                        on-change-script-entry)))
identity can be used instead of on-change-script-entry.


I think it will be hard to implement this service properly without
changing switch-generations function.  I'll try to think more about this
service someday.  For now I suggest to postpone it.
> Could you elaborate on what do you mean with this?
`guix home switch-generation` doesn't create new generations, but just
swapping symlinks and runs on-reconfigure script.
> What do you have in mind regarding changing switch-generations
> function?
I was referring switch-to-home-environment-generation

Without knowing which generation was previously, we can't make a proper
on-change service.  We can't get this information without modifying the
function I mentioned above.
Andrew Tropin <andrew@trop.in> writes:
Next
> Also, I find on-reconfigure to be a missleading script name, because
> in reality it should be on-switch script, or activation, or something
> like that.
FWIW we should probably do this before merging to Guix proper.
Xinglu Chen <public@yoctocell.xyz> writes:
Next
Pushed changes related to activation service and adjusted on-change
implementation accordingly, but there are a few notes regarding the
service logic itself.
Next
Export patchset (mbox)
How do I use this?

Copy & paste the following snippet into your terminal to import this patchset into git:

curl -s https://lists.sr.ht/~abcdw/rde-devel/patches/22290/mbox | git am -3
Learn more about email & git
View this thread in the archives

[PATCH 1/2] gnu: home-services: Add 'run-on-change' service. Export this patch

* gnu/home-services.scm (on-change-script-entry,
compute-on-change-script): New procedures.
(home-run-on-change-service-type): New service type.
---
 gnu/home-services.scm | 122 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 121 insertions(+), 1 deletion(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index d746724..8ea4461 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -8,16 +8,21 @@
  #:use-module (guix diagnostics)
  #:use-module (guix discovery)
  #:use-module (guix ui)
  ;; #:use-module (guix modules)
  #:use-module ((guix import utils) #:select (flatten))

  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)

  #:export (home-service-type
	    home-profile-service-type
	    home-environment-vars-service-type
	    home-run-on-first-login-service-type
	    home-run-on-reconfigure-service-type
           fold-home-service-types)
            home-run-on-change-service-type

            fold-home-service-types)

  #:re-export (service
	       service-type
@@ -198,7 +203,122 @@ in the home environment directory."
home during reconfiguration.  All gexps must be idempotent.  Can
be extended with one gexp.")))

(define (on-change-script-entry gexps)
  #~(begin #$gexps))

(define (compute-on-change-script _ gexps)
  #~(begin
      (use-modules (srfi srfi-1)
                   (ice-9 popen)
                   (ice-9 match)
                   (rnrs io ports))

      (define (load-tree path)
        (if (file-exists? path)
            (call-with-input-file path
              (lambda (port)
                (read port)))
            #f))

      (define (init lst)
        (drop-right lst 1))

      ;; Copied from (guix import utils)
      ;; TODO: Make upstream move it to (guix utils)?
      (define (flatten lst)
        "Return a list that recursively concatenates all sub-lists of LST."
        (fold-right
         (match-lambda*
           (((sub-list ...) memo)
            (append (flatten sub-list) memo))
           ((elem memo)
            (cons elem memo)))
         '() lst))

      (let* ((gexp-tuples '#$gexps)
             (tree-file-name "/.guix-home-environment-file-tree")
             (config-home    (or (getenv "XDG_CONFIG_HOME")
                                 (string-append (getenv "HOME") "/.config")))
             (tree-file-path (string-append config-home tree-file-name))
             (he-path (or (getenv "GUIX_HOME_ENVIRONMENT_DIRECTORY")
                          (string-append (getenv "HOME")
                                         "/.guix-home-environment")))
             (home-prefix (string-append (getenv "HOME") "/."))
             (tree-file (load-tree tree-file-path)))

        (define tree-file-files
          (map (lambda (pair) (cdr pair))
               (filter (lambda (pair) (equal? (car pair) 'file))
                       (flatten tree-file))))

        (define (different-files old-file new-file)
          "Check Whether OLD-FILE and NEW-FILE are bit for bit
identical.  If they aren't, return OLD-FILE with the
@file{/var/guix/profiles/per-user/USER/guix-home-environment-N-link/files}
prefix removed, otherwise, return @code{#f}.  If OLD-FILE doesn't
exist, do the same thing as if it was different from NEW-FILE."
          (catch 'error
            (lambda _
              (string-trim old-file
                           (string->char-set
                            (string-append previous-generation
                                           "/files/"))))
            (lambda _
              (unless (file-exists? old-file)
                (throw 'error))

              (let* ((pipe (open-pipe* OPEN_READ "cmp" old-file new-file))
                     (status (eof-object? (read pipe))))
                (close-pipe pipe)
                (if status
                    #f
                    (throw 'error))))))

        (define previous-generation
          ;; /var/guix/profiles/per-user/USER/guix-home-environment-$(N-1)-link
          (let* ((split (string-split (readlink (readlink he-path)) #\-))
                 (current-gen-number (string->number (last (init split)))))
            (string-append (string-join (init (init split)) "-" 'suffix)
                           (number->string (- current-gen-number 1))
                           "-link")))

        (define changed-files
          (map (match-lambda
                 ((old new) (different-files old new)))
               (zip
                ;; /var/guix/profiles/per-user/USER/guix-home-environment-$(N-1)-link/files/FILE-PATH
                (map (lambda (path) (string-append previous-generation
                                                   "/files/" path))
                     tree-file-files)
                ;; ~/.guix-home-environemnt/files/FILE-PATH
                (map (lambda (path) (string-append he-path "/files/" path))
                     tree-file-files))))

        (define (needed-gexps gexp-tuples)
          (let loop ((acc '())
                     (gexp-tuples gexp-tuples))
            (cond
             ((null? gexp-tuples) acc)
             ((member (first (first gexp-tuples)) changed-files)
              (loop (cons (second (first gexp-tuples)) acc) (cdr gexp-tuples)))
             (else (loop acc (cdr gexp-tuples))))))

        (for-each primitive-eval
                  (needed-gexps gexp-tuples)))))

(define home-run-on-change-service-type
  (service-type (name 'home-run-on-change)
                (extensions
                 (list (service-extension
                        home-run-on-reconfigure-service-type
                        on-change-script-entry)))
                (compose identity)
                (extend compute-on-change-script)
                (default-value '())
                (description "G-expression to run if the specified \
file has changed since the last generation.  The G-expression should \
be a list where the first element is the file that should be changed, \
and the second element is the G-expression to the run.")))

;; Used for searching for services
(define (parent-directory directory)
-- 
2.31.1

[PATCH v2 1/2] gnu: home-services: Add 'run-on-change' service. Export this patch

* gnu/home-services.scm (on-change-script-entry,
compute-on-change-gexp): New procedures.
(home-run-on-change-service-type): New service type.
* guix/scripts/home.scm (perform-action): Set GUIX_HOME_PREVIOUS_GENERATION
environment variable before switching to the new generation.
---
 gnu/home-services.scm | 114 +++++++++++++++++++++++++++++++++++++++++-
 guix/scripts/home.scm |  46 ++++++++++-------
 2 files changed, 141 insertions(+), 19 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 83105c4..0fad366 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -1,6 +1,7 @@
(define-module (gnu home-services)
  #:use-module (gnu services)
  #:use-module (gnu home-services-utils)
  #:use-module (gnu packages base)
  #:use-module (guix channels)
  #:use-module (guix describe)
  #:use-module (guix monads)
@@ -15,6 +16,12 @@
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  ;; #:use-module (guix modules)
  #:use-module ((guix import utils) #:select (flatten))

  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)

  #:export (home-service-type
	    home-profile-service-type
@@ -22,6 +29,8 @@
	    home-run-on-first-login-service-type
	    home-activation-service-type
	    home-provenance-service-type
            home-run-on-change-service-type

            fold-home-service-types)

  #:re-export (service
@@ -194,7 +203,15 @@ extended with one gexp.")))

(define (compute-activation-script init-gexp gexps)
  (gexp->script "activate"
		#~(begin #$init-gexp #$@gexps)))
                #~(begin
                    ;; Other services can provide G-exps that call
                    ;; this procedure.
                    (define (home-environment-directory)
                      (or (getenv "GUIX_HOME_DIRECTORY")
                          (string-append (getenv "HOME") "/.guix-home")))

                    #$init-gexp
                    #$@gexps)))

(define (activation-script-entry m-activation)
  "Return, as a monadic value, an entry for the activation script
@@ -217,7 +234,102 @@ directory.  @command{activate} script automatically called during
reconfiguration or generation switching.  This service can be extended
with one gexp, and all gexps must be idempotent.")))



;;;
;;; On-change.
;;;

(define (compute-on-change-gexp _ gexps)
  #~(begin
      (use-modules (srfi srfi-1)
                   (ice-9 popen)
                   (ice-9 match)
                   (rnrs io ports))

      (define (load-tree path)
        (if (file-exists? path)
            (call-with-input-file path
              (lambda (port)
                (read port)))
            #f))

      (define (butlast lst)
        (drop-right lst 1))

      (define rest cdr)

      ;; Copied from (guix import utils)
      ;; TODO: Make upstream move it to (guix build utils)?
      (define (flatten lst)
        "Return a list that recursively concatenates all sub-lists of LST."
        (fold-right
         (match-lambda*
           (((sub-list ...) memo)
            (append (flatten sub-list) memo))
           ((elem memo)
            (cons elem memo)))
         '() lst))

      (let* ((gexp-tuples '#$gexps)
             (tree-file-name "/.guix-home-file-tree")
             (config-home    (or (getenv "XDG_CONFIG_HOME")
                                 (string-append (getenv "HOME") "/.config")))
             (tree-file-path (string-append config-home tree-file-name))
             (current-generation (home-environment-directory))
             (previous-generation (getenv "GUIX_HOME_PREVIOUS_GENERATION"))
             (tree-file (load-tree tree-file-path)))
        (define tree-file-files
          (map (lambda (pair) (rest pair))
               (filter (lambda (pair) (equal? (car pair) 'file))
                       (flatten tree-file))))

        (define (check-file file)
          "Check Whether FILE for the current generation is identical
to the one for the previous generation identical.  If they aren't,
return FILE with the, otherwise, return @code{#f}."
          (let ((old-file-full-path (string-append previous-generation
                                                   "/files/" file))
                (new-file-full-path (string-append current-generation
                                                   "/files/" file)))
            (if (file-exists? old-file-full-path)
                (let* ((pipe (open-pipe*
                              OPEN_READ
                              (string-append #$diffutils "/bin/cmp")
                              old-file-full-path
                              new-file-full-path))
                       (status (eof-object? (read pipe))))
                  (close-pipe pipe)
                  (if status #f file))
                file)))

        (define changed-files
          (map (lambda (file) (check-file file)) tree-file-files))

        (define (needed-gexps gexp-tuples)
          (let loop ((acc '())
                     (gexp-tuples gexp-tuples))
            (cond
             ((null? gexp-tuples) acc)
             ((member (first (first gexp-tuples)) changed-files)
              (loop (cons (second (first gexp-tuples)) acc) (rest gexp-tuples)))
             (else (loop acc (rest gexp-tuples))))))

        (for-each primitive-eval
                  (needed-gexps gexp-tuples)))))

(define home-run-on-change-service-type
  (service-type (name 'home-run-on-change)
                (extensions
                 (list (service-extension
                        home-activation-service-type
                        identity)))
                (compose identity)
                (extend compute-on-change-gexp)
                (default-value '())
                (description "G-expression to run if the specified
file has changed since the last generation.  The G-expression should
be a list where the first element is the file that should be changed,
and the second element is the G-expression to the run.")))



;;;
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index d04f80b..61cd200 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -93,9 +93,9 @@ Some ACTIONS support additional ARGS.\n"))


(define* (perform-action action he
			 #:key
                         #:key
                         dry-run?
			 derivations-only?
                         derivations-only?
                         use-substitutes?)
  "Perform ACTION for home environment. "

@@ -107,33 +107,43 @@ Some ACTIONS support additional ARGS.\n"))
       (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
       (%        (if derivations-only?
                     (return
		      (for-each (compose println derivation-file-name) drvs))
                      (for-each (compose println derivation-file-name) drvs))
                     (built-derivations drvs)))

       (he-path -> (derivation->output-path he-drv)))
    (if (or dry-run? derivations-only?)
	(return #f)
        (return #f)
        (begin
          (for-each (compose println derivation->output-path) drvs)

          (case action
	    ((reconfigure)
	     (let* ((number (generation-number %guix-home))
            ((reconfigure)
             (let* ((number (generation-number %guix-home))
                    (generation (generation-file-name
				 %guix-home (+ 1 number)))

		    (user-home-environment-symlink-path
		     (home-environment-symlink-path he)))
	       (switch-symlinks generation he-path)
	       (switch-symlinks %guix-home generation)
	       (switch-symlinks user-home-environment-symlink-path
				%guix-home)

	       (primitive-load (string-append he-path "/activate"))
	       (return he-path)))
                                 %guix-home (+ 1 number)))

                    (user-home-environment-symlink-path
                     (home-environment-symlink-path he)))
               (define home-environment-directory
                 (or (getenv "GUIX_HOME_DIRECTORY")
                     (string-append (getenv "HOME") "/.guix-home")))
               
               (define (generation-directory home-environment)
                 (readlink (readlink home-environment)))
               
               (setenv "GUIX_HOME_PREVIOUS_GENERATION"
                       (generation-directory home-environment-directory))
               
               (switch-symlinks generation he-path)
               (switch-symlinks %guix-home generation)
               (switch-symlinks user-home-environment-symlink-path
                                %guix-home)

               (primitive-load (string-append he-path "/activate"))
               (return he-path)))
            (else
             (newline)
	     (return he-path)))))))
             (return he-path)))))))

(define (process-action action args opts)
  "Process ACTION, a sub-command, with the arguments are listed in ARGS.
-- 
2.31.1
Xinglu Chen <public@yoctocell.xyz> writes:
Pushed changes related to activation service and adjusted on-change
implementation accordingly, but there are a few notes regarding the
service logic itself.

[PATCH 2/2] gnu: home-services: xorg: Make Xresources extend Export this patch

* gnu/home-services/xorg.scm (home-xresources-run-on-change-service):
New procedure.
(home-xresources-service-type): Extend ‘home-run-on-change-service-type’.
---
 gnu/home-services/xorg.scm | 14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

diff --git a/gnu/home-services/xorg.scm b/gnu/home-services/xorg.scm
index 1dbe067..a487482 100644
--- a/gnu/home-services/xorg.scm
+++ b/gnu/home-services/xorg.scm
@@ -135,6 +135,15 @@ URxvt.secondaryScroll: 0
(define (home-xresources-profile-service config)
  (list (home-xresources-configuration-package config)))

(define (home-xresources-run-on-change-service config)
  #~("Xresources"
     (begin
       (system* #$(file-append (home-xresources-configuration-package config)
                               "/bin/xrdb")
                "-load"
                (string-append (getenv "GUIX_HOME_ENVIRONMENT_DIRECTORY")
                               "/files/Xresources")))))

(define (home-xresources-extension old-config extension-configs)
  (match old-config
    (($ <home-xresources-configuration> _ package* config*)
@@ -152,7 +161,10 @@ URxvt.secondaryScroll: 0
                        home-xresources-files-service)
                       (service-extension
                        home-profile-service-type
                        home-xresources-profile-service)))
                        home-xresources-profile-service)
                       (service-extension
                        home-run-on-change-service-type
                        home-xresources-run-on-change-service)))
                (compose concatenate)
                (extend home-xresources-extension)
                (default-value (home-xresources-configuration))
-- 
2.31.1
Very cool service idea! Thank you)
> +(define (on-change-script-entry gexps)
> +  #~(begin #$gexps))
Seems unecessary.
> +(define (compute-on-change-script _ gexps)
s/script/gexp/
> +      (define (init lst)
init can be confusing in some contexts, maybe butlast will work here?
> +      ;; TODO: Make upstream move it to (guix utils)?
or (guix build utils)
> +          (map (lambda (pair) (cdr pair))
(map cdr
> +                            (string-append previous-generation
Used before it defined, breaks the flow, complicates reading of the
code.
> +            (lambda _
> +              (unless (file-exists? old-file)
> +                (throw 'error))
Not a good idea to control the flow of the program with exceptions.
> +              (let* ((pipe (open-pipe* OPEN_READ "cmp" old-file new-file))
Full path to cmp is preffered. #$(file-append diffutils "/bin/cmp")
> +          ;; /var/guix/profiles/per-user/USER/guix-home-environment-$(N-1)-link
It can be not true if we switching generation.  Also, I find
on-reconfigure to be a missleading script name, because in reality it
should be on-switch script, or activation, or something like that.
> +          (map (match-lambda
> +                 ((old new) (different-files old new)))
> +               (zip
No need to zip here, map can accept few lists.
> +                 (list (service-extension
> +                        home-run-on-reconfigure-service-type
> +                        on-change-script-entry)))
identity can be used instead of on-change-script-entry.


I think it will be hard to implement this service properly without
changing switch-generations function.  I'll try to think more about this
service someday.  For now I suggest to postpone it.
> Could you elaborate on what do you mean with this?
`guix home switch-generation` doesn't create new generations, but just
swapping symlinks and runs on-reconfigure script.
> What do you have in mind regarding changing switch-generations
> function?
I was referring switch-to-home-environment-generation

Without knowing which generation was previously, we can't make a proper
on-change service.  We can't get this information without modifying the
function I mentioned above.

[PATCH v2 2/2] gnu: home-services: xorg: Make Xresources extend Export this patch

* gnu/home-services/xorg.scm (home-xresources-run-on-change-service):
New procedure.
(home-xresources-service-type): Extend
‘home-run-on-change-service-type’.
---
 gnu/home-services/xorg.scm | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

diff --git a/gnu/home-services/xorg.scm b/gnu/home-services/xorg.scm
index 6e260ac..24c5ead 100644
--- a/gnu/home-services/xorg.scm
+++ b/gnu/home-services/xorg.scm
@@ -133,6 +133,16 @@ URxvt.secondaryScroll: 0
(define (home-xresources-profile-service config)
  (list (home-xresources-configuration-package config)))

(define (home-xresources-run-on-change-service config)
  #~("Xresources"
     (begin
       (display "Reloading Xresources\n")
       (system* #$(file-append (home-xresources-configuration-package config)
                               "/bin/xrdb")
                "-load"
                (string-append (home-environment-directory)
                               "/files/Xresources")))))

(define (home-xresources-extension old-config extension-configs)
  (match old-config
    (($ <home-xresources-configuration> _ package* config*)
@@ -150,7 +160,10 @@ URxvt.secondaryScroll: 0
                        home-xresources-files-service)
                       (service-extension
                        home-profile-service-type
                        home-xresources-profile-service)))
                        home-xresources-profile-service)
                       (service-extension
                        home-run-on-change-service-type
                        home-xresources-run-on-change-service)))
                (compose concatenate)
                (extend home-xresources-extension)
                (default-value (home-xresources-configuration))
-- 
2.31.1