summary refs log tree commit diff
path: root/gnu/home/services
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-02-18 15:43:57 +0100
committerLudovic Courtès <ludo@gnu.org>2022-03-10 11:43:13 +0100
commit66bf60a4cd52a5ae973c7a892d2cd5950271c285 (patch)
treef285f3492e8e6562165705fa163db63bebd50891 /gnu/home/services
parent25afd66a818744a68899460a961bc170af176ce3 (diff)
downloadguix-66bf60a4cd52a5ae973c7a892d2cd5950271c285.tar.gz
home: symlink-manager: Clarify module imports.
* gnu/home/services/symlink-manager.scm (update-symlinks-script): Wrap
body in 'with-imported-modules'.  Move (guix build utils) import to the
top.  Move #$%initialize-gettext after definitions.
Diffstat (limited to 'gnu/home/services')
-rw-r--r--gnu/home/services/symlink-manager.scm342
1 files changed, 173 insertions, 169 deletions
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index 314da3ba3e..c60cdcffb7 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -20,7 +20,7 @@
 (define-module (gnu home services symlink-manager)
   #:use-module (gnu home services)
   #:use-module (guix gexp)
-
+  #:use-module (guix modules)
   #:export (home-symlink-manager-service-type))
 
 ;;; Comment:
@@ -37,15 +37,19 @@
 (define (update-symlinks-script)
   (program-file
    "update-symlinks"
-   #~(begin
-       (use-modules (ice-9 ftw)
-                    (ice-9 curried-definitions)
-                    (ice-9 match)
-                    (srfi srfi-1)
-                    (guix i18n))
-       #$%initialize-gettext
-       (define ((simplify-file-tree parent) file)
-         "Convert the result produced by `file-system-tree' to less
+   (with-imported-modules (source-module-closure
+                           '((guix build utils)
+                             (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
@@ -60,178 +64,178 @@ Sample output:
   ((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.
+           (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))))))
-
-       (use-modules (guix build utils))
-
-       (let* ((config-home    (or (getenv "XDG_CONFIG_HOME")
-                                  (string-append (getenv "HOME") "/.config")))
-
-              (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 "/."))
-
-              (home-path (getenv "HOME"))
-              (backup-dir (string-append home-path "/"
-                                         (number->string (current-time))
-                                         "-guix-home-legacy-configs-backup"))
-
-              (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)))
-
-              (get-source-path
-               (lambda (path)
-                 (readlink (string-append new-files-path "/" path))))
-
-              (get-target-path
-               (lambda (path)
-                 (string-append home-path "/." path)))
-
-              (get-backup-path
-               (lambda (path)
-                 (string-append backup-dir "/." path)))
-
-              (directory?
-               (lambda (path)
-                 (equal? (stat:type (stat path)) 'directory)))
-
-              (empty-directory?
-               (lambda (dir)
-                 (equal? (scandir dir) '("." ".."))))
-
-              (symlink-to-store?
-               (lambda (path)
-                 (and
-                  (equal? (stat:type (lstat path)) 'symlink)
-                  (store-file-name? (readlink path)))))
-
-              (backup-file
-               (lambda (path)
-                 (mkdir-p backup-dir)
-                 (format #t (G_ "Backing up ~a...") (get-target-path path))
-                 (mkdir-p (dirname (get-backup-path path)))
-                 (rename-file (get-target-path path) (get-backup-path path))
-                 (display (G_ " done\n"))))
-
-              (cleanup-symlinks
-               (lambda ()
-                 (let ((to-delete ((file-tree-traverse #f) old-tree)))
-                   (display
-                    (G_
-                    "Cleaning up symlinks from previous home-environment.\n\n"))
-                   (map
-                    (match-lambda
-                      (('dir . ".")
-                       (display (G_ "Cleanup finished.\n\n")))
-
-                      (('dir . path)
-                       (if (and
-                            (file-exists? (get-target-path path))
-                            (directory? (get-target-path path))
-                            (empty-directory? (get-target-path path)))
-                           (begin
-                             (format #t (G_ "Removing ~a...")
-                                     (get-target-path path))
-                             (rmdir (get-target-path path))
-                             (display (G_ " done\n")))
-                           (format
-                            #t
-                            (G_ "Skipping ~a (not an empty directory)... done\n")
-                            (get-target-path path))))
-
-                      (('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))
+           (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))))))
+
+         #$%initialize-gettext
+
+         (let* ((config-home    (or (getenv "XDG_CONFIG_HOME")
+                                    (string-append (getenv "HOME") "/.config")))
+
+                (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 "/."))
+
+                (home-path (getenv "HOME"))
+                (backup-dir (string-append home-path "/"
+                                           (number->string (current-time))
+                                           "-guix-home-legacy-configs-backup"))
+
+                (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)))
+
+                (get-source-path
+                 (lambda (path)
+                   (readlink (string-append new-files-path "/" path))))
+
+                (get-target-path
+                 (lambda (path)
+                   (string-append home-path "/." path)))
+
+                (get-backup-path
+                 (lambda (path)
+                   (string-append backup-dir "/." path)))
+
+                (directory?
+                 (lambda (path)
+                   (equal? (stat:type (stat path)) 'directory)))
+
+                (empty-directory?
+                 (lambda (dir)
+                   (equal? (scandir dir) '("." ".."))))
+
+                (symlink-to-store?
+                 (lambda (path)
+                   (and
+                    (equal? (stat:type (lstat path)) 'symlink)
+                    (store-file-name? (readlink path)))))
+
+                (backup-file
+                 (lambda (path)
+                   (mkdir-p backup-dir)
+                   (format #t (G_ "Backing up ~a...") (get-target-path path))
+                   (mkdir-p (dirname (get-backup-path path)))
+                   (rename-file (get-target-path path) (get-backup-path path))
+                   (display (G_ " done\n"))))
+
+                (cleanup-symlinks
+                 (lambda ()
+                   (let ((to-delete ((file-tree-traverse #f) old-tree)))
+                     (display
+                      (G_
+                       "Cleaning up symlinks from previous home-environment.\n\n"))
+                     (map
+                      (match-lambda
+                        (('dir . ".")
+                         (display (G_ "Cleanup finished.\n\n")))
+
+                        (('dir . path)
+                         (if (and
+                              (file-exists? (get-target-path path))
+                              (directory? (get-target-path path))
+                              (empty-directory? (get-target-path path)))
                              (begin
-                               (format #t (G_ "Removing ~a...") (get-target-path path))
-                               (delete-file (get-target-path path))
+                               (format #t (G_ "Removing ~a...")
+                                       (get-target-path path))
+                               (rmdir (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))))
-
-              (create-symlinks
-               (lambda ()
-                 (let ((to-create ((file-tree-traverse #t) new-tree)))
-                   (map
-                    (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))
-
-                      (('dir . path)
-                       (let ((target-path (get-target-path path)))
-                         (when (and (file-exists? target-path)
-                                    (not (directory? target-path)))
+                              (G_ "Skipping ~a (not an empty directory)... done\n")
+                              (get-target-path path))))
+
+                        (('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))))
+
+                (create-symlinks
+                 (lambda ()
+                   (let ((to-create ((file-tree-traverse #t) new-tree)))
+                     (map
+                      (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))
+
+                        (('dir . path)
+                         (let ((target-path (get-target-path path)))
+                           (when (and (file-exists? target-path)
+                                      (not (directory? target-path)))
+                             (backup-file 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 . 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)))))
 
-                         (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 . 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)))))
-
-         (when old-tree
-           (cleanup-symlinks))
+           (when old-tree
+             (cleanup-symlinks))
 
-         (create-symlinks)
+           (create-symlinks)
 
-         (symlink new-home new-he-path)
-         (rename-file new-he-path he-path)
+           (symlink new-home new-he-path)
+           (rename-file new-he-path he-path)
 
-         (display (G_" done\nFinished updating symlinks.\n\n"))))))
+           (display (G_" done\nFinished updating symlinks.\n\n")))))))
 
 
 (define (update-symlinks-gexp _)