mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 23:46:13 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
25afd66a81
commit
66bf60a4cd
1 changed files with 155 additions and 151 deletions
|
|
@ -20,7 +20,7 @@
|
||||||
(define-module (gnu home services symlink-manager)
|
(define-module (gnu home services symlink-manager)
|
||||||
#:use-module (gnu home services)
|
#:use-module (gnu home services)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
|
#:use-module (guix modules)
|
||||||
#:export (home-symlink-manager-service-type))
|
#:export (home-symlink-manager-service-type))
|
||||||
|
|
||||||
;;; Comment:
|
;;; Comment:
|
||||||
|
|
@ -37,15 +37,19 @@ (define-module (gnu home services symlink-manager)
|
||||||
(define (update-symlinks-script)
|
(define (update-symlinks-script)
|
||||||
(program-file
|
(program-file
|
||||||
"update-symlinks"
|
"update-symlinks"
|
||||||
#~(begin
|
(with-imported-modules (source-module-closure
|
||||||
(use-modules (ice-9 ftw)
|
'((guix build utils)
|
||||||
(ice-9 curried-definitions)
|
(guix i18n)))
|
||||||
(ice-9 match)
|
#~(begin
|
||||||
(srfi srfi-1)
|
(use-modules (ice-9 ftw)
|
||||||
(guix i18n))
|
(ice-9 curried-definitions)
|
||||||
#$%initialize-gettext
|
(ice-9 match)
|
||||||
(define ((simplify-file-tree parent) file)
|
(srfi srfi-1)
|
||||||
"Convert the result produced by `file-system-tree' to less
|
(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.
|
verbose and more suitable for further processing format.
|
||||||
|
|
||||||
Extract dir/file info from stat and compose a relative path to the
|
Extract dir/file info from stat and compose a relative path to the
|
||||||
|
|
@ -60,178 +64,178 @@ (define ((simplify-file-tree parent) file)
|
||||||
((dir . \"config/isync\")
|
((dir . \"config/isync\")
|
||||||
(file . \"config/isync/mbsyncrc\"))))
|
(file . \"config/isync/mbsyncrc\"))))
|
||||||
"
|
"
|
||||||
(match file
|
(match file
|
||||||
((name stat) `(file . ,(string-append parent name)))
|
((name stat) `(file . ,(string-append parent name)))
|
||||||
((name stat children ...)
|
((name stat children ...)
|
||||||
(cons `(dir . ,(string-append parent name))
|
(cons `(dir . ,(string-append parent name))
|
||||||
(map (simplify-file-tree
|
(map (simplify-file-tree
|
||||||
(if (equal? name ".")
|
(if (equal? name ".")
|
||||||
""
|
""
|
||||||
(string-append parent name "/")))
|
(string-append parent name "/")))
|
||||||
children)))))
|
children)))))
|
||||||
|
|
||||||
(define ((file-tree-traverse preordering) node)
|
(define ((file-tree-traverse preordering) node)
|
||||||
"Traverses the file tree in different orders, depending on PREORDERING.
|
"Traverses the file tree in different orders, depending on PREORDERING.
|
||||||
|
|
||||||
if PREORDERING is @code{#t} resulting list will contain directories
|
if PREORDERING is @code{#t} resulting list will contain directories
|
||||||
before files located in those directories, otherwise directory will
|
before files located in those directories, otherwise directory will
|
||||||
appear only after all nested items already listed."
|
appear only after all nested items already listed."
|
||||||
(let ((prepend (lambda (a b) (append b a))))
|
(let ((prepend (lambda (a b) (append b a))))
|
||||||
(match node
|
(match node
|
||||||
(('file . path) (list node))
|
(('file . path) (list node))
|
||||||
((('dir . path) . rest)
|
((('dir . path) . rest)
|
||||||
((if preordering append prepend)
|
((if preordering append prepend)
|
||||||
(list (cons 'dir path))
|
(list (cons 'dir path))
|
||||||
(append-map (file-tree-traverse preordering) rest))))))
|
(append-map (file-tree-traverse preordering) rest))))))
|
||||||
|
|
||||||
(use-modules (guix build utils))
|
#$%initialize-gettext
|
||||||
|
|
||||||
(let* ((config-home (or (getenv "XDG_CONFIG_HOME")
|
(let* ((config-home (or (getenv "XDG_CONFIG_HOME")
|
||||||
(string-append (getenv "HOME") "/.config")))
|
(string-append (getenv "HOME") "/.config")))
|
||||||
|
|
||||||
(he-path (string-append (getenv "HOME") "/.guix-home"))
|
(he-path (string-append (getenv "HOME") "/.guix-home"))
|
||||||
(new-he-path (string-append he-path ".new"))
|
(new-he-path (string-append he-path ".new"))
|
||||||
(new-home (getenv "GUIX_NEW_HOME"))
|
(new-home (getenv "GUIX_NEW_HOME"))
|
||||||
(old-home (getenv "GUIX_OLD_HOME"))
|
(old-home (getenv "GUIX_OLD_HOME"))
|
||||||
|
|
||||||
(new-files-path (string-append new-home "/files"))
|
(new-files-path (string-append new-home "/files"))
|
||||||
;; Trailing dot is required, because files itself is symlink and
|
;; Trailing dot is required, because files itself is symlink and
|
||||||
;; to make file-system-tree works it should be a directory.
|
;; to make file-system-tree works it should be a directory.
|
||||||
(new-files-dir-path (string-append new-files-path "/."))
|
(new-files-dir-path (string-append new-files-path "/."))
|
||||||
|
|
||||||
(home-path (getenv "HOME"))
|
(home-path (getenv "HOME"))
|
||||||
(backup-dir (string-append home-path "/"
|
(backup-dir (string-append home-path "/"
|
||||||
(number->string (current-time))
|
(number->string (current-time))
|
||||||
"-guix-home-legacy-configs-backup"))
|
"-guix-home-legacy-configs-backup"))
|
||||||
|
|
||||||
(old-tree (if old-home
|
(old-tree (if old-home
|
||||||
((simplify-file-tree "")
|
((simplify-file-tree "")
|
||||||
(file-system-tree
|
(file-system-tree
|
||||||
(string-append old-home "/files/.")))
|
(string-append old-home "/files/.")))
|
||||||
#f))
|
#f))
|
||||||
(new-tree ((simplify-file-tree "")
|
(new-tree ((simplify-file-tree "")
|
||||||
(file-system-tree new-files-dir-path)))
|
(file-system-tree new-files-dir-path)))
|
||||||
|
|
||||||
(get-source-path
|
(get-source-path
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(readlink (string-append new-files-path "/" path))))
|
(readlink (string-append new-files-path "/" path))))
|
||||||
|
|
||||||
(get-target-path
|
(get-target-path
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(string-append home-path "/." path)))
|
(string-append home-path "/." path)))
|
||||||
|
|
||||||
(get-backup-path
|
(get-backup-path
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(string-append backup-dir "/." path)))
|
(string-append backup-dir "/." path)))
|
||||||
|
|
||||||
(directory?
|
(directory?
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(equal? (stat:type (stat path)) 'directory)))
|
(equal? (stat:type (stat path)) 'directory)))
|
||||||
|
|
||||||
(empty-directory?
|
(empty-directory?
|
||||||
(lambda (dir)
|
(lambda (dir)
|
||||||
(equal? (scandir dir) '("." ".."))))
|
(equal? (scandir dir) '("." ".."))))
|
||||||
|
|
||||||
(symlink-to-store?
|
(symlink-to-store?
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(and
|
(and
|
||||||
(equal? (stat:type (lstat path)) 'symlink)
|
(equal? (stat:type (lstat path)) 'symlink)
|
||||||
(store-file-name? (readlink path)))))
|
(store-file-name? (readlink path)))))
|
||||||
|
|
||||||
(backup-file
|
(backup-file
|
||||||
(lambda (path)
|
(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
|
(cleanup-symlinks
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((to-delete ((file-tree-traverse #f) old-tree)))
|
(let ((to-delete ((file-tree-traverse #f) old-tree)))
|
||||||
(display
|
(display
|
||||||
(G_
|
(G_
|
||||||
"Cleaning up symlinks from previous home-environment.\n\n"))
|
"Cleaning up symlinks from previous home-environment.\n\n"))
|
||||||
(map
|
(map
|
||||||
(match-lambda
|
(match-lambda
|
||||||
(('dir . ".")
|
(('dir . ".")
|
||||||
(display (G_ "Cleanup finished.\n\n")))
|
(display (G_ "Cleanup finished.\n\n")))
|
||||||
|
|
||||||
(('dir . path)
|
(('dir . path)
|
||||||
(if (and
|
(if (and
|
||||||
(file-exists? (get-target-path path))
|
(file-exists? (get-target-path path))
|
||||||
(directory? (get-target-path path))
|
(directory? (get-target-path path))
|
||||||
(empty-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
|
(begin
|
||||||
(format #t (G_ "Removing ~a...") (get-target-path path))
|
(format #t (G_ "Removing ~a...")
|
||||||
(delete-file (get-target-path path))
|
(get-target-path path))
|
||||||
|
(rmdir (get-target-path path))
|
||||||
(display (G_ " done\n")))
|
(display (G_ " done\n")))
|
||||||
(format
|
(format
|
||||||
#t
|
#t
|
||||||
(G_ "Skipping ~a (not a symlink to store)... done\n")
|
(G_ "Skipping ~a (not an empty directory)... done\n")
|
||||||
(get-target-path path))))))
|
(get-target-path path))))
|
||||||
to-delete))))
|
|
||||||
|
|
||||||
(create-symlinks
|
(('file . path)
|
||||||
(lambda ()
|
(when (file-exists? (get-target-path path))
|
||||||
(let ((to-create ((file-tree-traverse #t) new-tree)))
|
;; DO NOT remove the file if it is no longer
|
||||||
(map
|
;; a symlink to the store, it will be backed
|
||||||
(match-lambda
|
;; up later during create-symlinks phase.
|
||||||
(('dir . ".")
|
(if (symlink-to-store? (get-target-path path))
|
||||||
(display
|
(begin
|
||||||
(G_ "New symlinks to home-environment will be created soon.\n"))
|
(format #t (G_ "Removing ~a...") (get-target-path path))
|
||||||
(format
|
(delete-file (get-target-path path))
|
||||||
#t (G_ "All conflicting files will go to ~a.\n\n") backup-dir))
|
(display (G_ " done\n")))
|
||||||
|
(format
|
||||||
|
#t
|
||||||
|
(G_ "Skipping ~a (not a symlink to store)... done\n")
|
||||||
|
(get-target-path path))))))
|
||||||
|
to-delete))))
|
||||||
|
|
||||||
(('dir . path)
|
(create-symlinks
|
||||||
(let ((target-path (get-target-path path)))
|
(lambda ()
|
||||||
(when (and (file-exists? target-path)
|
(let ((to-create ((file-tree-traverse #t) new-tree)))
|
||||||
(not (directory? target-path)))
|
(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))
|
(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)
|
(when old-tree
|
||||||
(format
|
(cleanup-symlinks))
|
||||||
#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)
|
(create-symlinks)
|
||||||
(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
|
(symlink new-home new-he-path)
|
||||||
(cleanup-symlinks))
|
(rename-file new-he-path he-path)
|
||||||
|
|
||||||
(create-symlinks)
|
(display (G_" done\nFinished updating symlinks.\n\n")))))))
|
||||||
|
|
||||||
(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 _)
|
(define (update-symlinks-gexp _)
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue