mirror of https://codeberg.org/glenneth/stash.git
feat: improve symlink handling in file-ops
- Add proper symlink preservation when stashing - Handle existing symlinks correctly - Maintain symlink chains when moving to dotfiles - Fix path handling for .config directory
This commit is contained in:
GLENN THOMPSON
parent
478ba3ae92
commit
14b20d6028
|
|
@ -4,6 +4,7 @@
|
|||
#:use-module (stash log) ;; Import log-action, current-timestamp
|
||||
#:use-module (stash paths) ;; Import expand-home, concat-path, ensure-config-path
|
||||
#:use-module (stash conflict) ;; Import prompt-user-for-action, handle-conflict
|
||||
#:use-module (stash package) ;; Import package record type
|
||||
#:use-module (ice-9 ftw) ;; For file tree walk
|
||||
#:export (move-source-to-target
|
||||
create-symlink
|
||||
|
|
@ -31,40 +32,71 @@
|
|||
;;; Helper function to delete a directory recursively
|
||||
(define (delete-directory path)
|
||||
"Delete a directory recursively."
|
||||
(if (file-is-directory? path)
|
||||
(begin
|
||||
(system (string-append "rm -rf " (shell-quote-argument path)))
|
||||
(log-action (format #f "Deleted directory: ~a" path)))
|
||||
(display "Error: Path is not a directory.\n")))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(if (file-is-directory? real-path)
|
||||
(begin
|
||||
(system (string-append "rm -rf " (shell-quote-argument real-path)))
|
||||
(log-action (format #f "Deleted directory: ~a" real-path)))
|
||||
(display "Error: Path is not a directory.\n"))))
|
||||
|
||||
;;; Helper function to move source to target
|
||||
(define (move-source-to-target source-dir target-dir)
|
||||
"Move the entire source directory to the target directory, ensuring .config in the target path."
|
||||
(let* ((target-dir (ensure-config-path target-dir)) ;; Use ensure-config-path from paths.scm
|
||||
(source-dir (expand-home source-dir)) ;; Use expand-home from paths.scm
|
||||
(source-name (basename source-dir))
|
||||
(target-source-dir (concat-path target-dir source-name))) ;; Use concat-path from paths.scm
|
||||
;; Ensure that the .config directory exists in the target
|
||||
(if (not (file-exists? target-dir))
|
||||
(mkdir target-dir #o755))
|
||||
;; Check if the target directory already exists
|
||||
(if (file-exists? target-source-dir)
|
||||
(handle-conflict target-source-dir source-dir delete-directory log-action) ;; Conflict handling
|
||||
;; If the target directory doesn't exist, proceed with the move
|
||||
(source-dir (if (package? source-dir)
|
||||
(package-source source-dir)
|
||||
(expand-home source-dir))) ;; Use expand-home from paths.scm
|
||||
(backup-dir (string-append source-dir ".bak"))) ;; Create backup path
|
||||
;; Ensure that all parent directories exist
|
||||
(mkdir-p (dirname target-dir))
|
||||
;; Handle symlinks specially
|
||||
(if (file-is-symlink? source-dir)
|
||||
(let ((link-target (readlink source-dir)))
|
||||
(display (format #f "Moving symlink from ~a to ~a (pointing to ~a)\n" source-dir target-dir link-target))
|
||||
;; Remove existing symlinks if they exist
|
||||
(when (file-exists? target-dir)
|
||||
(delete-file target-dir)
|
||||
(log-action (format #f "Removed existing symlink at ~a" target-dir)))
|
||||
(when (file-exists? source-dir)
|
||||
(delete-file source-dir)
|
||||
(log-action (format #f "Removed existing symlink at ~a" source-dir)))
|
||||
;; Create the new symlink at target location
|
||||
(symlink link-target target-dir)
|
||||
(log-action (format #f "Created symlink at ~a pointing to ~a" target-dir link-target))
|
||||
;; Create a symlink back to the target
|
||||
(symlink target-dir source-dir)
|
||||
(log-action (format #f "Created reverse symlink at ~a pointing to ~a" source-dir target-dir)))
|
||||
;; For regular files/directories
|
||||
(begin
|
||||
;; Try rename-file first (fast but only works on same device)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(rename-file source-dir target-source-dir)
|
||||
(display (format #f "Moved ~a to ~a\n" source-dir target-source-dir))
|
||||
(log-action (format #f "Moved ~a to ~a" source-dir target-source-dir)))
|
||||
(lambda args
|
||||
;; If rename-file fails, fall back to cp -R and rm -rf
|
||||
(system (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument target-source-dir)))
|
||||
(system (string-append "rm -rf " (shell-quote-argument source-dir)))
|
||||
(display (format #f "Moved (via copy) ~a to ~a\n" source-dir target-source-dir))
|
||||
(log-action (format #f "Moved (via copy) ~a to ~a" source-dir target-source-dir))))))
|
||||
target-source-dir)) ;; Return the path of the moved source directory
|
||||
;; Create backup before moving
|
||||
(when (file-exists? source-dir)
|
||||
(system (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument backup-dir)))
|
||||
(log-action (format #f "Created backup at ~a" backup-dir)))
|
||||
;; Check if the target directory already exists
|
||||
(if (file-exists? target-dir)
|
||||
(handle-conflict target-dir source-dir delete-directory log-action)
|
||||
;; If the target directory doesn't exist, proceed with the move
|
||||
(begin
|
||||
;; Always use cp first, then verify, then remove source
|
||||
(let ((cp-command (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument target-dir))))
|
||||
(if (= 0 (system cp-command))
|
||||
(begin
|
||||
(display (format #f "Copied ~a to ~a\n" source-dir target-dir))
|
||||
(log-action (format #f "Copied ~a to ~a" source-dir target-dir))
|
||||
;; Only remove source if copy was successful
|
||||
(system (string-append "rm -rf " (shell-quote-argument source-dir)))
|
||||
(display (format #f "Removed source after successful copy: ~a\n" source-dir))
|
||||
(log-action (format #f "Removed source after successful copy: ~a" source-dir)))
|
||||
(begin
|
||||
(display (format #f "Error: Failed to copy ~a to ~a\n" source-dir target-dir))
|
||||
(log-action (format #f "Error: Failed to copy ~a to ~a" source-dir target-dir))
|
||||
;; Restore from backup if copy failed
|
||||
(when (file-exists? backup-dir)
|
||||
(system (string-append "cp -R " (shell-quote-argument backup-dir) " " (shell-quote-argument source-dir)))
|
||||
(log-action (format #f "Restored from backup: ~a" backup-dir))))))))))
|
||||
target-dir)) ;; Return the path of the moved directory
|
||||
|
||||
;;; Helper function to create a symlink
|
||||
(define (create-symlink source target)
|
||||
|
|
@ -83,18 +115,33 @@
|
|||
"Check if a path is a symbolic link."
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(eq? 'symlink (stat:type (lstat path))))
|
||||
(eq? 'symlink (stat:type (lstat (if (package? path)
|
||||
(package-source path)
|
||||
path)))))
|
||||
(lambda args #f)))
|
||||
|
||||
;;; Helper function to check if a path is a directory
|
||||
(define (file-is-directory? path)
|
||||
"Check if a path is a directory."
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(eq? 'directory (stat:type (lstat (if (package? path)
|
||||
(package-source path)
|
||||
path)))))
|
||||
(lambda args #f)))
|
||||
|
||||
;;; Helper function to create parent directories recursively
|
||||
(define (mkdir-p path)
|
||||
"Create directory and parent directories if they don't exist."
|
||||
(display (format #f "Creating parent directory: ~a\n" path))
|
||||
(let ((parent (dirname path)))
|
||||
(when (not (file-exists? parent))
|
||||
(mkdir-p parent))
|
||||
(when (not (file-exists? path))
|
||||
(mkdir path #o755))))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(display (format #f "Creating parent directory: ~a\n" real-path))
|
||||
(let ((parent (dirname real-path)))
|
||||
(when (not (file-exists? parent))
|
||||
(mkdir-p parent))
|
||||
(when (not (file-exists? real-path))
|
||||
(mkdir real-path #o755)))))
|
||||
|
||||
;;; Helper function to execute operations
|
||||
(define (execute-operations operations)
|
||||
|
|
@ -115,46 +162,79 @@
|
|||
|
||||
(define (ensure-directory dir)
|
||||
"Create directory if it doesn't exist"
|
||||
(when (not (file-exists? dir))
|
||||
(mkdir-p dir)))
|
||||
(let ((real-dir (if (package? dir)
|
||||
(package-source dir)
|
||||
dir)))
|
||||
(when (not (file-exists? real-dir))
|
||||
(mkdir-p real-dir))))
|
||||
|
||||
(define (copy-recursive source target)
|
||||
"Copy directory recursively"
|
||||
(system (string-append "cp -R " (shell-quote-argument source) " " (shell-quote-argument target))))
|
||||
(let ((real-source (if (package? source)
|
||||
(package-source source)
|
||||
source))
|
||||
(real-target (if (package? target)
|
||||
(package-source target)
|
||||
target)))
|
||||
(system (string-append "cp -R "
|
||||
(shell-quote-argument real-source) " "
|
||||
(shell-quote-argument real-target)))))
|
||||
|
||||
(define (delete-recursive path)
|
||||
"Delete file or directory recursively"
|
||||
(system (string-append "rm -rf " (shell-quote-argument path))))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(system (string-append "rm -rf " (shell-quote-argument real-path)))))
|
||||
|
||||
(define (make-file-executable path)
|
||||
"Make file executable"
|
||||
(chmod path (logior (stat:mode (stat path)) execute-permission)))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(chmod real-path (logior (stat:mode (stat real-path)) execute-permission))))
|
||||
|
||||
(define (make-file-readable path)
|
||||
"Make file readable"
|
||||
(chmod path (logior (stat:mode (stat path)) read-permission)))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(chmod real-path (logior (stat:mode (stat real-path)) read-permission))))
|
||||
|
||||
(define (file-is-executable? path)
|
||||
"Check if file is executable"
|
||||
(let ((mode (stat:mode (stat path))))
|
||||
(let ((mode (stat:mode (stat (if (package? path)
|
||||
(package-source path)
|
||||
path)))))
|
||||
(not (zero? (logand mode execute-permission)))))
|
||||
|
||||
(define (file-is-readable? path)
|
||||
"Check if file is readable"
|
||||
(let ((mode (stat:mode (stat path))))
|
||||
(let ((mode (stat:mode (stat (if (package? path)
|
||||
(package-source path)
|
||||
path)))))
|
||||
(not (zero? (logand mode read-permission)))))
|
||||
|
||||
(define (resolve-symlink path)
|
||||
"Resolve symlink to its target"
|
||||
(if (file-is-symlink? path)
|
||||
(readlink path)
|
||||
path))
|
||||
(let ((real-path (if (package? path)
|
||||
(package-source path)
|
||||
path)))
|
||||
(if (file-is-symlink? real-path)
|
||||
(readlink real-path)
|
||||
real-path)))
|
||||
|
||||
(define (update-symlink target link)
|
||||
"Update or create symlink"
|
||||
(when (file-exists? link)
|
||||
(delete-file link))
|
||||
(symlink target link))
|
||||
(let ((real-target (if (package? target)
|
||||
(package-source target)
|
||||
target))
|
||||
(real-link (if (package? link)
|
||||
(package-source link)
|
||||
link)))
|
||||
(when (file-exists? real-link)
|
||||
(delete-file real-link))
|
||||
(symlink real-target real-link)))
|
||||
|
||||
;;; Export list
|
||||
(export mkdir-p
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(define-module (stash paths)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (srfi srfi-1) ; For drop
|
||||
#:export (expand-home
|
||||
normalize-path
|
||||
relative-path
|
||||
|
|
@ -28,7 +29,8 @@
|
|||
(let ((target-dir (expand-home target-dir)))
|
||||
(if (string-suffix? "/" target-dir)
|
||||
(set! target-dir (string-drop-right target-dir 1))) ;; Remove trailing slash if it exists
|
||||
(if (not (string-suffix? "/.config" target-dir))
|
||||
(if (and (not (string-suffix? "/.config" target-dir))
|
||||
(not (string-contains target-dir "/.config/"))) ;; Don't add .config if it's already in the path
|
||||
(string-append target-dir "/.config")
|
||||
target-dir)))
|
||||
|
||||
|
|
@ -71,12 +73,12 @@
|
|||
(string=? (list-ref base-parts i)
|
||||
(list-ref target-parts i)))
|
||||
(loop (+ i 1))
|
||||
i)))
|
||||
(up-count (- (length base-parts) common-prefix-length))
|
||||
(down-parts (list-tail target-parts common-prefix-length)))
|
||||
(if (and (= up-count 0) (null? down-parts))
|
||||
"."
|
||||
(string-join
|
||||
(append (make-list up-count "..")
|
||||
down-parts)
|
||||
"/"))))
|
||||
i))))
|
||||
;; Drop common prefix from both paths
|
||||
(let* ((base-unique (drop base-parts common-prefix-length))
|
||||
(target-unique (drop target-parts common-prefix-length))
|
||||
(up-dirs (make-list (length base-unique) ".."))
|
||||
(relative-parts (append up-dirs target-unique)))
|
||||
(if (null? relative-parts)
|
||||
"."
|
||||
(string-join relative-parts "/")))))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
#:use-module (stash file-ops)
|
||||
#:use-module (stash log)
|
||||
#:use-module (stash paths)
|
||||
#:use-module (stash package) ; For package record type
|
||||
#:export (analyze-tree
|
||||
fold-tree
|
||||
plan-operations
|
||||
|
|
@ -16,7 +17,8 @@
|
|||
(ice-9 regex)
|
||||
(srfi srfi-1)
|
||||
(stash file-ops)
|
||||
(stash paths))
|
||||
(stash paths)
|
||||
(stash package))
|
||||
|
||||
;; Tree node record type
|
||||
(define-record-type <tree-node>
|
||||
|
|
@ -27,26 +29,34 @@
|
|||
(children node-children))
|
||||
|
||||
;; Analyze directory tree and create tree structure
|
||||
(define* (analyze-tree root-path #:optional (ignore-patterns '()))
|
||||
(let analyze ((path root-path))
|
||||
(cond
|
||||
((file-is-symlink? path)
|
||||
(make-tree-node path 'symlink '()))
|
||||
((file-is-directory? path)
|
||||
(let* ((entries (scandir path))
|
||||
(children (filter-map
|
||||
(lambda (entry)
|
||||
(if (or (member entry '("." ".."))
|
||||
(and (not (null? ignore-patterns))
|
||||
(any (lambda (pattern)
|
||||
(string-match pattern entry))
|
||||
ignore-patterns)))
|
||||
#f
|
||||
(analyze (string-append path "/" entry))))
|
||||
entries)))
|
||||
(make-tree-node path 'directory children)))
|
||||
(else
|
||||
(make-tree-node path 'file '())))))
|
||||
(define (analyze-tree input)
|
||||
"Create a tree structure from a directory path or package.
|
||||
If input is a package, uses package-source and package ignores.
|
||||
If input is a string, treats it as a path with no ignores."
|
||||
(let* ((path (if (package? input)
|
||||
(package-source input)
|
||||
input))
|
||||
(should-include? (if (package? input)
|
||||
(lambda (file-path)
|
||||
(should-include-file? input file-path))
|
||||
(lambda (file-path) #t))))
|
||||
(let analyze ((path path))
|
||||
(cond
|
||||
((file-is-symlink? path)
|
||||
(make-tree-node path 'symlink '()))
|
||||
((file-is-directory? path)
|
||||
(let* ((entries (scandir path))
|
||||
(children (filter-map
|
||||
(lambda (entry)
|
||||
(if (or (member entry '("." ".."))
|
||||
(not (should-include?
|
||||
(string-append path "/" entry))))
|
||||
#f
|
||||
(analyze (string-append path "/" entry))))
|
||||
entries)))
|
||||
(make-tree-node path 'directory children)))
|
||||
(else
|
||||
(make-tree-node path 'file '()))))))
|
||||
|
||||
;; Fold over a tree structure
|
||||
(define (fold-tree proc init tree)
|
||||
|
|
@ -81,21 +91,27 @@
|
|||
(check-children (cdr children))))))))
|
||||
|
||||
;; Plan stow operations for a tree
|
||||
(define (plan-operations tree target-dir)
|
||||
(let ((source-base (node-path tree)))
|
||||
(fold-tree
|
||||
(lambda (node acc)
|
||||
(let* ((relative-path (relative-path source-base (node-path node)))
|
||||
(target-path (string-append target-dir "/" relative-path)))
|
||||
(cond
|
||||
((eq? (node-type node) 'directory)
|
||||
(if (not (file-exists? target-path))
|
||||
(cons `(mkdir ,target-path) acc)
|
||||
acc))
|
||||
((eq? (node-type node) 'file)
|
||||
(if (not (file-exists? target-path))
|
||||
(cons `(symlink ,(node-path node) ,target-path) acc)
|
||||
acc))
|
||||
(else acc))))
|
||||
'()
|
||||
tree)))
|
||||
(define (plan-operations tree target)
|
||||
"Plan operations for stowing files. Target can be either a string path or a package."
|
||||
(let* ((target-dir (if (package? target)
|
||||
(package-target target)
|
||||
target))
|
||||
(source-base (node-path tree)))
|
||||
;; First move the source directory to target
|
||||
(cons `(move ,source-base ,target-dir)
|
||||
(fold-tree
|
||||
(lambda (node acc)
|
||||
(let* ((relative-path (relative-path source-base (node-path node)))
|
||||
(target-path (string-append target-dir "/" relative-path))
|
||||
(source-path (node-path node)))
|
||||
(cond
|
||||
((eq? (node-type node) 'directory)
|
||||
(if (not (file-exists? target-path))
|
||||
(cons `(mkdir ,target-path) acc)
|
||||
acc))
|
||||
((eq? (node-type node) 'file)
|
||||
;; Create symlink in original location pointing to new location
|
||||
(cons `(symlink ,target-path ,source-path) acc))
|
||||
(else acc))))
|
||||
'()
|
||||
tree))))
|
||||
|
|
|
|||
|
|
@ -46,13 +46,14 @@
|
|||
|
||||
(define (handle-explicit-stash source target recursive?)
|
||||
"Handle stashing with explicit source and target paths."
|
||||
(let* ((source-path (canonicalize-path source))
|
||||
(target-path (canonicalize-path target))
|
||||
(let* ((source-path (normalize-path source))
|
||||
(target-path (normalize-path target))
|
||||
(package-name (basename source-path))
|
||||
(ignore-patterns (read-ignore-patterns source-path)))
|
||||
(ignore-patterns (read-ignore-patterns source-path))
|
||||
(package (make-package package-name source-path target-path ignore-patterns)))
|
||||
(if recursive?
|
||||
(handle-recursive-stash source-path target-path)
|
||||
(let ((package (make-package package-name source-path target-path ignore-patterns)))
|
||||
(begin
|
||||
(process-package package)
|
||||
#t))))
|
||||
|
||||
|
|
|
|||
|
|
@ -38,6 +38,15 @@
|
|||
;; Test operation planning
|
||||
(let* ((tree (scan-directory source-dir))
|
||||
(ops (plan-operations tree target-dir)))
|
||||
|
||||
;; First operation should be to move the source directory
|
||||
(test-assert "Should plan to move source to target"
|
||||
(and (pair? ops)
|
||||
(eq? (caar ops) 'move)
|
||||
(string=? (cadar ops) source-dir)
|
||||
(string=? (caddar ops) target-dir)))
|
||||
|
||||
;; Should create target directory structure
|
||||
(test-assert "Should plan to create target directory"
|
||||
(any (lambda (op)
|
||||
(and (eq? (car op) 'mkdir)
|
||||
|
|
@ -45,11 +54,14 @@
|
|||
(string-append target-dir "/dir"))))
|
||||
ops))
|
||||
|
||||
;; Should create symlinks in source pointing to target
|
||||
(test-assert "Should plan to create symlinks"
|
||||
(any (lambda (op)
|
||||
(and (eq? (car op) 'symlink)
|
||||
(string=? (cadr op)
|
||||
(string-append target-dir "/config.txt"))
|
||||
(string=? (caddr op)
|
||||
(string-append target-dir "/config.txt"))))
|
||||
(string-append source-dir "/config.txt"))))
|
||||
ops))))))
|
||||
|
||||
(test-end "tree")
|
||||
|
|
|
|||
Loading…
Reference in New Issue