~abcdw/rde-devel

Make ‘run-on-change’ service support any file or directory in ~/.guix-home v1 APPLIED

This series does a few things:

* Compare the symlinks of a file from the new generation and the old
  generation instead of comparing the content using ‘cmp’.  This is a
  considerably cheaper operation.

* Don’t read anything from the ‘guix-home-file-tree’ file, ‘gexp-tuples’
  already contains all the information we need.  Plus, the
  ‘guix-home-file-tree’ file is not read-only so it could be modified by
  the user.

* Support comparing any files in the ~/.guix-home directory, not just
  files in ~/.guix-home/files, which was the case previously.

* Add support for comparing directories, this will recursively traverse
  a directory and compare all the files that the directory contains.
  But if the directory itself is a symlink, it will be compared just as
  if it was a file.

* Adjust fonts and Xresources service to these new updates.

Xinglu Chen (5):
  gnu: home-services: Make ‘run-on-change’ service compare symlinks.
  gnu: home-services: Don’t read files from ‘guix-home-file-tree’.
  gnu: home-services: Make ‘run-on-change’ service support directories.
  gnu: home-services: fontutils: Extend ‘run-on-change’ service.
  gnu: home-services: xorg: Adjust to new ‘run-on-change’ service.

 gnu/home-services.scm           | 128 +++++++++++++++++++++-----------
 gnu/home-services/fontutils.scm |   8 +-
 gnu/home-services/xorg.scm      |   4 +-
 3 files changed, 92 insertions(+), 48 deletions(-)


base-commit: cd7a30e9f860899a11bfad0e42d283ed746b7250
-- 
2.32.0
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/23262/mbox | git am -3
Learn more about email & git
View this thread in the archives

[PATCH 1/5] gnu: home-services: Make ‘run-on-change’ service compare symlinks. Export this patch

* gnu/home-services.scm (compute-on-change-gexp): Compare the path of
the symlink to the store between two files instead of comparing the
content of the files.  This is a cheaper operation compared to the
previous approach.

Suggested-by: Andrew Tropin <andrew@trop.in>
Link: <https://lists.sr.ht/~abcdw/rde-devel/patches/22290#%3C5c49ad975bfb35aa38dccab08bc2269837502160.1622921967.git.public@yoctocell.xyz%3E-123>
---
 gnu/home-services.scm | 64 ++++++++++++++++++++++++++-----------------
 1 file changed, 39 insertions(+), 25 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 8c9368a..04da889 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -290,8 +290,6 @@ with one gexp, but many times, and all gexps must be idempotent.")))
      (define (butlast lst)
        (drop-right lst 1))

      (define rest cdr)

      (define (flatten . lst)
        "Return a list that recursively concatenates all sub-lists of LST."
        (define (flatten1 head out)
@@ -305,45 +303,61 @@ with one gexp, but many times, and all gexps must be idempotent.")))
             (config-home    (or (getenv "XDG_CONFIG_HOME")
                                 (string-append (getenv "HOME") "/.config")))
             (tree-file-path (string-append config-home tree-file-name))
             (current-generation (getenv "GUIX_NEW_HOME"))
             (previous-generation (getenv "GUIX_OLD_HOME"))
             (new-generation (getenv "GUIX_NEW_HOME"))
             (old-generation (getenv "GUIX_OLD_HOME"))
             (tree-file (load-tree tree-file-path)))
        (define tree-file-files
          (map cdr (filter (lambda (pair) (equal? (car pair) 'file))
                           (flatten tree-file))))

        (define (symlink? file)
          (let ((file-info (lstat file)))
            (eq? (vector-ref file-info 13) 'symlink)))

        (define (readlink* file)
          "Like @code{readlink}, but recursive."
          (cond
           ((not (symlink? file)) file)
           (else (readlink* (readlink 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)))

        (when (and previous-generation (file-exists? previous-generation))
          (let ((new-file (string-append new-generation file))
                (old-file (string-append old-generation file)))
            (cond
             ;; If the files don't exist in either generation, don't
             ;; do anything.
             ((and (not (file-exists? new-file))
                   (not (file-exists? old-file)))
              #f)
             ;; If the file exists in one of the generations,
             ;; something has definitely changed.
             ((or (and (not (file-exists? old-file)) (file-exists? new-file))
                  (and (file-exists? old-file) (not (file-exists? new-file))))
              file)
             ;; If the file exists in both generations, check for
             ;; identity.
             (else
              (if (string=? (readlink* old-file)
                            (readlink* new-file))
                  #f
                  file)))))

        (when (and old-generation (file-exists? old-generation))
          (let* ((changed-files
                  (map (lambda (file) (check-file file)) tree-file-files))
                  (map check-file files-to-check))
                 (needed-gexps
                  (lambda (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))))))))
                       ((member (caar gexp-tuples) changed-files)
                        (loop (cons (cadar gexp-tuples) acc)
                              (cdr gexp-tuples)))
                       (else (loop acc (cdr gexp-tuples))))))))

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

[PATCH 2/5] gnu: home-services: Don’t read files from ‘guix-home-file-tree’. Export this patch

* gnu/home-services.scm (compute-on-change-gexp): Don’t read files
from the ‘guix-home-file-tree’ file, the relevant files are already
provided in ‘gexp-tuples’.
---
 gnu/home-services.scm | 22 ++++------------------
 1 file changed, 4 insertions(+), 18 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 04da889..02a0940 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -280,13 +280,6 @@ with one gexp, but many times, and all gexps must be idempotent.")))
                   (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))

@@ -298,17 +291,10 @@ with one gexp, but many times, and all gexps must be idempotent.")))
              (cons head out)))
        (fold-right flatten1 '() 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))
             (new-generation (getenv "GUIX_NEW_HOME"))
             (old-generation (getenv "GUIX_OLD_HOME"))
             (tree-file (load-tree tree-file-path)))
        (define tree-file-files
          (map cdr (filter (lambda (pair) (equal? (car pair) 'file))
                           (flatten tree-file))))
      (let ((gexp-tuples '#$gexps)
            (new-generation (getenv "GUIX_NEW_HOME"))
            (old-generation (getenv "GUIX_OLD_HOME")))
        (define files-to-check (map car gexp-tuples))

        (define (symlink? file)
          (let ((file-info (lstat file)))
-- 
2.32.0

[PATCH 3/5] gnu: home-services: Make ‘run-on-change’ service support directories. Export this patch

* gnu/home-services.scm (compute-on-change-gexp): Recursively scan a
directory for files and check if they are identical to the ones for
the old generation.
---
 gnu/home-services.scm | 50 ++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 45 insertions(+), 5 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 02a0940..9fe7a1b 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -278,6 +278,7 @@ with one gexp, but many times, and all gexps must be idempotent.")))
      (use-modules (srfi srfi-1)
                   (ice-9 popen)
                   (ice-9 match)
                   (ice-9 ftw)
                   (rnrs io ports))

      (define (butlast lst)
@@ -306,10 +307,44 @@ with one gexp, but many times, and all gexps must be idempotent.")))
           ((not (symlink? file)) file)
           (else (readlink* (readlink file)))))

        (define (check-directory dir)
          "Traverse DIR and check whether all the files in DIR are
identical to the ones for the old generation."
          ;; We have DIR, which is
          ;;
          ;; /gnu/store/...-home/some/path/to/dir
          ;;
          ;; and we want to extract /some/path/to/dir.  If DIR has in
          ;; fact changed we just want to return /some/path/to/dir and
          ;; not the full path DIR because /some/path/to/dir is what
          ;; is specified as the path in `gexp-tuples'.
          (define path-from-generation-dir
            (let ((dir-length (string-length new-generation)))
              (string-drop dir dir-length)))

          (define (filter-file-tree-node node)
            (if (eq? (car node) 'dir)
                '()
                (cdr node)))

          (define (parent-or-current-dir dir)
            (or (string=? dir ".")
                (string=? dir "..")))

          (let ((children (map (lambda (dir)
                                 (string-append
                                  path-from-generation-dir "/" dir))
                               (filter (compose not parent-or-current-dir)
                                       (scandir dir)))))
            (if (any identity (flatten (map check-file children)))
                path-from-generation-dir
                #f)))

        (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}."
          "Check Whether FILE for the current generation is identical to the one
for the old generation.  If they aren't, return FILE with
the, otherwise, return @code{#f}.  This also works if the FILE is a
directory and the directory itself is a symlink to the store."
          (let ((new-file (string-append new-generation file))
                (old-file (string-append old-generation file)))
            (cond
@@ -325,11 +360,16 @@ return FILE with the, otherwise, return @code{#f}."
              file)
             ;; If the file exists in both generations, check for
             ;; identity.
             (else
             ((symlink? new-file)
              (if (string=? (readlink* old-file)
                            (readlink* new-file))
                  #f
                  file)))))
                  file))
             (else
              (begin
                (newline)

                (check-directory new-file))))))

        (when (and old-generation (file-exists? old-generation))
          (let* ((changed-files
-- 
2.32.0

[PATCH 4/5] gnu: home-services: fontutils: Extend ‘run-on-change’ service. Export this patch

* gnu/home-services/fontutils.scm (home-fontconfig-service-type):
Extend ‘run-on-change’ instead of ‘activation’.
(regenerate-font-cache-gexp): Adjust a accordingly.
---
 gnu/home-services/fontutils.scm | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/gnu/home-services/fontutils.scm b/gnu/home-services/fontutils.scm
index eacdc92..e07dced 100644
--- a/gnu/home-services/fontutils.scm
+++ b/gnu/home-services/fontutils.scm
@@ -28,7 +28,11 @@
;; TODO: fc-cache -f is too slow, it can be called only on-change or
;; workarounded some other way.
(define (regenerate-font-cache-gexp _)
  #~(system* "fc-cache" "-f"))
  #~("/profile/share/fonts"
      (begin
        (system* #$(file-append fontconfig
                                "/bin/fc-cache")
                 "-fv"))))

(define home-fontconfig-service-type
  (service-type (name 'home-fontconfig)
@@ -37,7 +41,7 @@
                        home-files-service-type
                        add-fontconfig-config-file)
                       (service-extension
                        home-activation-service-type
                        home-run-on-change-service-type
                        regenerate-font-cache-gexp)
                       (service-extension
                        home-profile-service-type
-- 
2.32.0

[PATCH 5/5] gnu: home-services: xorg: Adjust to new ‘run-on-change’ service. Export this patch

* gnu/home-services/xorg.scm (home-xresources-run-on-change-service):
Adjust to changes in the ‘run-on-change’ service.
---
 gnu/home-services/xorg.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/home-services/xorg.scm b/gnu/home-services/xorg.scm
index 24c5ead..bba042f 100644
--- a/gnu/home-services/xorg.scm
+++ b/gnu/home-services/xorg.scm
@@ -134,13 +134,13 @@ URxvt.secondaryScroll: 0
  (list (home-xresources-configuration-package config)))

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

(define (home-xresources-extension old-config extension-configs)
-- 
2.32.0