15/16: home: symlink-manager: 'create-symlinks' uses 'file-system-fold'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 1fb6ef0473fa6d5f14883156dccde0597dddd5a3
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Feb 26 21:35:17 2022 +0100

    home: symlink-manager: 'create-symlinks' uses 'file-system-fold'.
    
    This removes the need for two intermediate representations of the file
    tree.
    
    * gnu/home/services/symlink-manager.scm (update-symlinks-script)
    [simplify-file-tree, file-tree-traverse]: Remove.
    [create-symlinks]: Rewrite in terms of 'file-system-fold'.
---
 gnu/home/services/symlink-manager.scm | 128 ++++++++++++----------------------
 1 file changed, 43 insertions(+), 85 deletions(-)

diff --git a/gnu/home/services/symlink-manager.scm 
b/gnu/home/services/symlink-manager.scm
index 4f827c0360..16e2e7b772 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -43,52 +43,11 @@
                              (guix i18n)))
      #~(begin
          (use-modules (ice-9 ftw)
-                      (ice-9 curried-definitions)
                       (ice-9 match)
                       (srfi srfi-1)
                       (guix i18n)
                       (guix build utils))
 
-         (define ((simplify-file-tree parent) file)
-           "Convert the result produced by `file-system-tree' to less
-verbose and more suitable for further processing format.
-
-Extract dir/file info from stat and compose a relative path to the
-root of the file tree.
-
-Sample output:
-
-((dir . \".\")
- ((dir . \"config\")
-  ((dir . \"config/fontconfig\")
-   (file . \"config/fontconfig/fonts.conf\"))
-  ((dir . \"config/isync\")
-   (file . \"config/isync/mbsyncrc\"))))
-"
-           (match file
-             ((name stat) `(file . ,(string-append parent name)))
-             ((name stat children ...)
-              (cons `(dir . ,(string-append parent name))
-                    (map (simplify-file-tree
-                          (if (equal? name ".")
-                              ""
-                              (string-append parent name "/")))
-                         children)))))
-
-         (define ((file-tree-traverse preordering) node)
-           "Traverses the file tree in different orders, depending on 
PREORDERING.
-
-if PREORDERING is @code{#t} resulting list will contain directories
-before files located in those directories, otherwise directory will
-appear only after all nested items already listed."
-           (let ((prepend (lambda (a b) (append b a))))
-             (match node
-               (('file . path) (list node))
-               ((('dir . path) . rest)
-                ((if preordering append prepend)
-                 (list (cons 'dir path))
-                 (append-map (file-tree-traverse preordering) rest))))))
-
          (define home-path
            (getenv "HOME"))
 
@@ -176,64 +135,63 @@ appear only after all nested items already listed."
 
            (display (G_ "Cleanup finished.\n\n")))
 
-         (define (create-symlinks new-tree new-files-path)
-           ;; Create in directory NEW-TREE symlinks to the files under
-           ;; NEW-FILES-PATH, creating backups as needed.
-           (define (get-source-path path)
-             (readlink (string-append new-files-path "/" path)))
+         (define (create-symlinks home-generation)
+           ;; Create in $HOME symlinks for the files in HOME-GENERATION.
+           (define config-file-directory
+             ;; Note: Trailing slash is needed because "files" is a symlink.
+             (string-append home-generation "/files/"))
 
-           (let ((to-create ((file-tree-traverse #t) new-tree)))
-             (for-each
-              (match-lambda
-                (('dir . ".")
-                 (display
-                  (G_ "New symlinks to home-environment will be created 
soon.\n"))
-                 (format
-                  #t (G_ "All conflicting files will go to ~a.\n\n") 
backup-dir))
+           (define (strip file)
+             (string-drop file
+                          (+ 1 (string-length config-file-directory))))
 
-                (('dir . path)
-                 (let ((target-path (get-target-path path)))
-                   (when (and (file-exists? target-path)
-                              (not (file-is-directory? target-path)))
-                     (backup-file path))
+           (define (get-source-path path)
+             (readlink (string-append config-file-directory path)))
 
-                   (if (file-exists? target-path)
-                       (format
-                        #t (G_ "Skipping   ~a (directory already exists)... 
done\n")
-                        target-path)
-                       (begin
-                         (format #t (G_ "Creating   ~a...") target-path)
-                         (mkdir target-path)
-                         (display (G_ " done\n"))))))
+           (file-system-fold
+            (const #t)                            ;enter?
+            (lambda (file stat result)            ;leaf
+              (let ((source (get-source-path (strip file)))
+                    (target (get-target-path (strip file))))
+                (when (file-exists? target)
+                  (backup-file (strip file)))
+                (format #t (G_ "Symlinking ~a -> ~a...")
+                        target source)
+                (symlink source target)
+                (display (G_ " done\n"))))
+            (lambda (directory stat result)       ;down
+              (unless (string=? directory config-file-directory)
+                (let ((target (get-target-path (strip directory))))
+                  (when (and (file-exists? target)
+                             (not (file-is-directory? target)))
+                    (backup-file (strip directory)))
 
-                (('file . path)
-                 (when (file-exists? (get-target-path path))
-                   (backup-file path))
-                 (format #t (G_ "Symlinking ~a -> ~a...")
-                         (get-target-path path) (get-source-path path))
-                 (symlink (get-source-path path) (get-target-path path))
-                 (display (G_ " done\n"))))
-              to-create)))
+                  (catch 'system-error
+                    (lambda ()
+                      (mkdir target))
+                    (lambda args
+                      (let ((errno (system-error-errno args)))
+                        (unless (= EEXIST errno)
+                          (format #t (G_ "failed to create directory ~a: ~s~%")
+                                  target (strerror errno))
+                          (apply throw args))))))))
+            (const #t)                            ;up
+            (const #t)                            ;skip
+            (const #t)                            ;error
+            #t                                    ;init
+            config-file-directory))
 
          #$%initialize-gettext
 
          (let* ((he-path (string-append (getenv "HOME") "/.guix-home"))
                 (new-he-path (string-append he-path ".new"))
                 (new-home (getenv "GUIX_NEW_HOME"))
-                (old-home (getenv "GUIX_OLD_HOME"))
-
-                (new-files-path (string-append new-home "/files"))
-                ;; Trailing dot is required, because files itself is symlink 
and
-                ;; to make file-system-tree works it should be a directory.
-                (new-files-dir-path (string-append new-files-path "/."))
-
-                (new-tree ((simplify-file-tree "")
-                           (file-system-tree new-files-dir-path))))
+                (old-home (getenv "GUIX_OLD_HOME")))
 
            (when old-home
              (cleanup-symlinks old-home))
 
-           (create-symlinks new-tree new-files-path)
+           (create-symlinks new-home)
 
            (symlink new-home new-he-path)
            (rename-file new-he-path he-path)