ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 23:46:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2022-02-18 23:34:34 +01:00
parent 5fabaf1128
commit 5fa188e92e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 57 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

107
gnu/home/services/symlink-manager.scm
View file

@ -118,51 +118,63 @@ (define (backup-file 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")))
(define (cleanup-symlinks old-tree) (define (cleanup-symlinks home-generation)
;; Delete from directory OLD-TREE symlinks that correspond to a ;; Delete from $HOME files that originate in HOME-GENERATION, the
;; previous generation. ;; store item containing a home generation.
(let ((to-delete ((file-tree-traverse #f) old-tree))) (define config-file-directory
(display ;; Note: Trailing slash is needed because "files" is a symlink.
(G_ (string-append home-generation "/files/"))
"Cleaning up symlinks from previous home-environment.\n\n"))
(for-each
(match-lambda
(('dir . ".")
(display (G_ "Cleanup finished.\n\n")))
(('dir . directory) (define (strip file)
(let ((directory (get-target-path directory))) (string-drop file
(catch 'system-error (+ 1 (string-length config-file-directory))))
(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) (format #t (G_ "Cleaning up symlinks from previous home at ~a.~%")
(when (file-exists? (get-target-path path)) home-generation)
;; DO NOT remove the file if it is no longer a symlink to (newline)
;; the store, it will be backed up later during
;; create-symlinks phase. (file-system-fold
(if (symlink-to-store? (get-target-path path)) (const #t)
(begin (lambda (file stat _) ;leaf
(format #t (G_ "Removing ~a...") (get-target-path path)) (let ((file (get-target-path (strip file))))
(delete-file (get-target-path path)) (when (file-exists? file)
(display (G_ " done\n"))) ;; DO NOT remove the file if it is no longer a symlink to
(format ;; the store, it will be backed up later during
#t ;; create-symlinks phase.
(G_ "Skipping ~a (not a symlink to store)... done\n") (if (symlink-to-store? file)
(get-target-path path)))))) (begin
to-delete))) (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) (define (create-symlinks new-tree new-files-path)
;; Create in directory NEW-TREE symlinks to the files under ;; Create in directory NEW-TREE symlinks to the files under
@ -215,16 +227,11 @@ (define (get-source-path path)
;; 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 "/."))
(old-tree (if old-home
((simplify-file-tree "")
(file-system-tree
(string-append old-home "/files/.")))
#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))))
(when old-tree (when old-home
(cleanup-symlinks old-tree)) (cleanup-symlinks old-home))
(create-symlinks new-tree new-files-path) (create-symlinks new-tree new-files-path)