me
/
guix
Archived
1
0
Fork 0
Code

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 2022-02-18 16:58:27 +01:00
parent 66bf60a4cd
commit 7a8856f540
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 116 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
gnu/home/services/symlink-manager.scm
View File

@ -88,70 +88,39 @@ appear only after all nested items already listed."
(list (cons 'dir path)) (list (cons 'dir path))
(append-map (file-tree-traverse preordering) rest)))))) (append-map (file-tree-traverse preordering) rest))))))
#$%initialize-gettext (define home-path
(getenv "HOME"))
(let* ((config-home (or (getenv "XDG_CONFIG_HOME") (define backup-dir
(string-append (getenv "HOME") "/.config"))) (string-append home-path "/" (number->string (current-time))
(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")) "-guix-home-legacy-configs-backup"))
(old-tree (if old-home (define (get-target-path path)
((simplify-file-tree "") (string-append home-path "/." path))
(file-system-tree
(string-append old-home "/files/.")))
#f))
(new-tree ((simplify-file-tree "")
(file-system-tree new-files-dir-path)))
(get-source-path (define (get-backup-path path)
(lambda (path) (string-append backup-dir "/." path))
(readlink (string-append new-files-path "/" path))))
(get-target-path (define (directory? path)
(lambda (path) (equal? (stat:type (stat path)) 'directory))
(string-append home-path "/." path)))
(get-backup-path (define (empty-directory? dir)
(lambda (path) (equal? (scandir dir) '("." "..")))
(string-append backup-dir "/." path)))
(directory? (define (symlink-to-store? path)
(lambda (path) (and (equal? (stat:type (lstat path)) 'symlink)
(equal? (stat:type (stat path)) 'directory))) (store-file-name? (readlink path))))
(empty-directory? (define (backup-file path)
(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) (mkdir-p backup-dir)
(format #t (G_ "Backing up ~a...") (get-target-path path)) (format #t (G_ "Backing up ~a...") (get-target-path path))
(mkdir-p (dirname (get-backup-path path))) (mkdir-p (dirname (get-backup-path path)))
(rename-file (get-target-path path) (get-backup-path path)) (rename-file (get-target-path path) (get-backup-path path))
(display (G_ " done\n")))) (display (G_ " done\n")))
(cleanup-symlinks (define (cleanup-symlinks old-tree)
(lambda () ;; Delete from directory OLD-TREE symlinks that correspond to a
;; previous generation.
(let ((to-delete ((file-tree-traverse #f) old-tree))) (let ((to-delete ((file-tree-traverse #f) old-tree)))
(display (display
(G_ (G_
@ -178,9 +147,9 @@ appear only after all nested items already listed."
(('file . path) (('file . path)
(when (file-exists? (get-target-path path)) (when (file-exists? (get-target-path path))
;; DO NOT remove the file if it is no longer ;; DO NOT remove the file if it is no longer a symlink to
;; a symlink to the store, it will be backed ;; the store, it will be backed up later during
;; up later during create-symlinks phase. ;; create-symlinks phase.
(if (symlink-to-store? (get-target-path path)) (if (symlink-to-store? (get-target-path path))
(begin (begin
(format #t (G_ "Removing ~a...") (get-target-path path)) (format #t (G_ "Removing ~a...") (get-target-path path))
@ -190,10 +159,14 @@ appear only after all nested items already listed."
#t #t
(G_ "Skipping ~a (not a symlink to store)... done\n") (G_ "Skipping ~a (not a symlink to store)... done\n")
(get-target-path path)))))) (get-target-path path))))))
to-delete)))) 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)))
(create-symlinks
(lambda ()
(let ((to-create ((file-tree-traverse #t) new-tree))) (let ((to-create ((file-tree-traverse #t) new-tree)))
(map (map
(match-lambda (match-lambda
@ -225,19 +198,38 @@ appear only after all nested items already listed."
(get-target-path path) (get-source-path path)) (get-target-path path) (get-source-path path))
(symlink (get-source-path path) (get-target-path path)) (symlink (get-source-path path) (get-target-path path))
(display (G_ " done\n")))) (display (G_ " done\n"))))
to-create))))) to-create)))
#$%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 "/."))
(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 (when old-tree
(cleanup-symlinks)) (cleanup-symlinks old-tree))
(create-symlinks) (create-symlinks new-tree new-files-path)
(symlink new-home new-he-path) (symlink new-home new-he-path)
(rename-file new-he-path 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 _) (define (update-symlinks-gexp _)
#~(primitive-load #$(update-symlinks-script))) #~(primitive-load #$(update-symlinks-script)))