14/16: home: symlink-manager: 'cleanup-symlinks' uses 'file-system-fold'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5fa188e92e0c8e49766f357079fa0a216a988427
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Feb 18 23:34:34 2022 +0100

    home: symlink-manager: 'cleanup-symlinks' uses 'file-system-fold'.
    
    * gnu/home/services/symlink-manager.scm 
(update-symlinks-script)[cleanup-symlinks]:
    Take a home generation and iterate over its config files directly with
    'file-system-fold'.  Adjuster caller accordingly.  Remove 'old-tree'.
---
 gnu/home/services/symlink-manager.scm | 111 ++++++++++++++++++----------------
 1 file changed, 59 insertions(+), 52 deletions(-)

diff --git a/gnu/home/services/symlink-manager.scm 
b/gnu/home/services/symlink-manager.scm
index ba42424e8e..4f827c0360 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -118,51 +118,63 @@ appear only after all nested items already listed."
            (rename-file (get-target-path path) (get-backup-path path))
            (display (G_ " done\n")))
 
-         (define (cleanup-symlinks old-tree)
-           ;; Delete from directory OLD-TREE symlinks that correspond to a
-           ;; previous generation.
-           (let ((to-delete ((file-tree-traverse #f) old-tree)))
-             (display
-              (G_
-               "Cleaning up symlinks from previous home-environment.\n\n"))
-             (for-each
-              (match-lambda
-                (('dir . ".")
-                 (display (G_ "Cleanup finished.\n\n")))
-
-                (('dir . directory)
-                 (let ((directory (get-target-path directory)))
-                   (catch 'system-error
-                     (lambda ()
-                       (rmdir directory)
-                       (format #t (G_ "Removed ~a.\n") directory))
-                     (lambda args
-                       (let ((errno (system-error-errno args)))
-                         (cond ((= ENOTEMPTY errno)
-                                (format
-                                 #t
-                                 (G_ "Skipping ~a (not an empty 
directory)...\n")
-                                 directory))
-                               ((= ENOTDIR errno)
-                                #t)
-                               (else
-                                (apply throw args))))))))
-
-                (('file . path)
-                 (when (file-exists? (get-target-path path))
-                   ;; DO NOT remove the file if it is no longer a symlink to
-                   ;; the store, it will be backed up later during
-                   ;; create-symlinks phase.
-                   (if (symlink-to-store? (get-target-path path))
-                       (begin
-                         (format #t (G_ "Removing ~a...") (get-target-path 
path))
-                         (delete-file (get-target-path path))
-                         (display (G_ " done\n")))
-                       (format
-                        #t
-                        (G_ "Skipping ~a (not a symlink to store)... done\n")
-                        (get-target-path path))))))
-              to-delete)))
+         (define (cleanup-symlinks home-generation)
+           ;; Delete from $HOME files that originate in HOME-GENERATION, the
+           ;; store item containing a home generation.
+           (define config-file-directory
+             ;; Note: Trailing slash is needed because "files" is a symlink.
+             (string-append home-generation "/files/"))
+
+           (define (strip file)
+             (string-drop file
+                          (+ 1 (string-length config-file-directory))))
+
+           (format #t (G_ "Cleaning up symlinks from previous home at ~a.~%")
+                   home-generation)
+           (newline)
+
+           (file-system-fold
+            (const #t)
+            (lambda (file stat _)                 ;leaf
+              (let ((file (get-target-path (strip file))))
+                (when (file-exists? file)
+                  ;; DO NOT remove the file if it is no longer a symlink to
+                  ;; the store, it will be backed up later during
+                  ;; create-symlinks phase.
+                  (if (symlink-to-store? file)
+                      (begin
+                        (format #t (G_ "Removing ~a...") file)
+                        (delete-file file)
+                        (display (G_ " done\n")))
+                      (format #t
+                              (G_ "Skipping ~a (not a symlink to store)... 
done\n")
+                              file)))))
+
+            (const #t)                            ;down
+            (lambda (directory stat _)            ;up
+              (unless (string=? directory config-file-directory)
+                (let ((directory (get-target-path (strip directory))))
+                  (catch 'system-error
+                    (lambda ()
+                      (rmdir directory)
+                      (format #t (G_ "Removed ~a.\n") directory))
+                    (lambda args
+                      (let ((errno (system-error-errno args)))
+                        (cond ((= ENOTEMPTY errno)
+                               (format
+                                #t
+                                (G_ "Skipping ~a (not an empty 
directory)...\n")
+                                directory))
+                              ((= ENOTDIR errno) #t)
+                              (else
+                               (apply throw args)))))))))
+            (const #t)                            ;skip
+            (const #t)                            ;error
+            #t                                    ;init
+            config-file-directory
+            lstat)
+
+           (display (G_ "Cleanup finished.\n\n")))
 
          (define (create-symlinks new-tree new-files-path)
            ;; Create in directory NEW-TREE symlinks to the files under
@@ -215,16 +227,11 @@ appear only after all nested items already listed."
                 ;; to make file-system-tree works it should be a directory.
                 (new-files-dir-path (string-append new-files-path "/."))
 
-                (old-tree (if old-home
-                              ((simplify-file-tree "")
-                               (file-system-tree
-                                (string-append old-home "/files/.")))
-                              #f))
                 (new-tree ((simplify-file-tree "")
                            (file-system-tree new-files-dir-path))))
 
-           (when old-tree
-             (cleanup-symlinks old-tree))
+           (when old-home
+             (cleanup-symlinks old-home))
 
            (create-symlinks new-tree new-files-path)