home: symlink-manager: Move helper procedures as top-level defines.
* gnu/home/services/symlink-manager.scm (update-symlinks-script): Remove 'config-home', which is unused. Move 'home-path', 'backup-dir', 'get-target-path', 'get-backup-path', 'directory?', 'empty-directory?', 'symlink-to-store?', and 'backup-file' to the top level. Move 'create-symlinks' and 'cleanup-symlinks' to the top level as well, and add parameters. Adjust callers.master
Ludovic Courtès
parent
66bf60a4cd
commit
7a8856f540
|
|
@ -88,12 +88,121 @@ appear only after all nested items already listed."
|
|||
(list (cons 'dir path))
|
||||
(append-map (file-tree-traverse preordering) rest))))))
|
||||
|
||||
(define home-path
|
||||
(getenv "HOME"))
|
||||
|
||||
(define backup-dir
|
||||
(string-append home-path "/" (number->string (current-time))
|
||||
"-guix-home-legacy-configs-backup"))
|
||||
|
||||
(define (get-target-path path)
|
||||
(string-append home-path "/." path))
|
||||
|
||||
(define (get-backup-path path)
|
||||
(string-append backup-dir "/." path))
|
||||
|
||||
(define (directory? path)
|
||||
(equal? (stat:type (stat path)) 'directory))
|
||||
|
||||
(define (empty-directory? dir)
|
||||
(equal? (scandir dir) '("." "..")))
|
||||
|
||||
(define (symlink-to-store? path)
|
||||
(and (equal? (stat:type (lstat path)) 'symlink)
|
||||
(store-file-name? (readlink path))))
|
||||
|
||||
(define (backup-file 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")))
|
||||
|
||||
(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"))
|
||||
(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))
|
||||
(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 (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)))
|
||||
|
||||
(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)))
|
||||
|
||||
#$%initialize-gettext
|
||||
|
||||
(let* ((config-home (or (getenv "XDG_CONFIG_HOME")
|
||||
(string-append (getenv "HOME") "/.config")))
|
||||
|
||||
(he-path (string-append (getenv "HOME") "/.guix-home"))
|
||||
(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"))
|
||||
|
|
@ -103,141 +212,24 @@ 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 "/."))
|
||||
|
||||
(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))
|
||||
(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)))))
|
||||
(file-system-tree new-files-dir-path))))
|
||||
|
||||
(when old-tree
|
||||
(cleanup-symlinks))
|
||||
(cleanup-symlinks old-tree))
|
||||
|
||||
(create-symlinks)
|
||||
(create-symlinks new-tree new-files-path)
|
||||
|
||||
(symlink new-home new-he-path)
|
||||
(rename-file new-he-path he-path)
|
||||
|
||||
(display (G_" done\nFinished updating symlinks.\n\n")))))))
|
||||
|
||||
|
||||
(define (update-symlinks-gexp _)
|
||||
#~(primitive-load #$(update-symlinks-script)))
|
||||
|
||||
|
|
|
|||
Reference in New Issue