glenn
/
stash
mirror of https://codeberg.org/glenneth/stash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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 2024-12-06 19:31:47 +03:00
parent 478ba3ae92
commit 14b20d6028
5 changed files with 214 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
modules/stash/file-ops.scm
View File

@ -4,6 +4,7 @@
#:use-module (stash log) ;; Import log-action, current-timestamp #:use-module (stash log) ;; Import log-action, current-timestamp
#:use-module (stash paths) ;; Import expand-home, concat-path, ensure-config-path #: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 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 #:use-module (ice-9 ftw) ;; For file tree walk
#:export (move-source-to-target #:export (move-source-to-target
create-symlink create-symlink
@ -31,40 +32,71 @@
;;; Helper function to delete a directory recursively ;;; Helper function to delete a directory recursively
(define (delete-directory path) (define (delete-directory path)
"Delete a directory recursively." "Delete a directory recursively."
(if (file-is-directory? path) (let ((real-path (if (package? path)
(begin (package-source path)
(system (string-append "rm -rf " (shell-quote-argument path))) path)))
(log-action (format #f "Deleted directory: ~a" path))) (if (file-is-directory? real-path)
(display "Error: Path is not a directory.\n"))) (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 ;;; Helper function to move source to target
(define (move-source-to-target source-dir target-dir) (define (move-source-to-target source-dir target-dir)
"Move the entire source directory to the target directory, ensuring .config in the target path." "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 (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-dir (if (package? source-dir)
(source-name (basename source-dir)) (package-source source-dir)
(target-source-dir (concat-path target-dir source-name))) ;; Use concat-path from paths.scm (expand-home source-dir))) ;; Use expand-home from paths.scm
;; Ensure that the .config directory exists in the target (backup-dir (string-append source-dir ".bak"))) ;; Create backup path
(if (not (file-exists? target-dir)) ;; Ensure that all parent directories exist
(mkdir target-dir #o755)) (mkdir-p (dirname target-dir))
;; Check if the target directory already exists ;; Handle symlinks specially
(if (file-exists? target-source-dir) (if (file-is-symlink? source-dir)
(handle-conflict target-source-dir source-dir delete-directory log-action) ;; Conflict handling (let ((link-target (readlink source-dir)))
;; If the target directory doesn't exist, proceed with the move (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 (begin
;; Try rename-file first (fast but only works on same device) ;; Create backup before moving
(catch 'system-error (when (file-exists? source-dir)
(lambda () (system (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument backup-dir)))
(rename-file source-dir target-source-dir) (log-action (format #f "Created backup at ~a" backup-dir)))
(display (format #f "Moved ~a to ~a\n" source-dir target-source-dir)) ;; Check if the target directory already exists
(log-action (format #f "Moved ~a to ~a" source-dir target-source-dir))) (if (file-exists? target-dir)
(lambda args (handle-conflict target-dir source-dir delete-directory log-action)
;; If rename-file fails, fall back to cp -R and rm -rf ;; If the target directory doesn't exist, proceed with the move
(system (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument target-source-dir))) (begin
(system (string-append "rm -rf " (shell-quote-argument source-dir))) ;; Always use cp first, then verify, then remove source
(display (format #f "Moved (via copy) ~a to ~a\n" source-dir target-source-dir)) (let ((cp-command (string-append "cp -R " (shell-quote-argument source-dir) " " (shell-quote-argument target-dir))))
(log-action (format #f "Moved (via copy) ~a to ~a" source-dir target-source-dir)))))) (if (= 0 (system cp-command))
target-source-dir)) ;; Return the path of the moved source directory (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 ;;; Helper function to create a symlink
(define (create-symlink source target) (define (create-symlink source target)
@ -83,18 +115,33 @@
"Check if a path is a symbolic link." "Check if a path is a symbolic link."
(catch 'system-error (catch 'system-error
(lambda () (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))) (lambda args #f)))
;;; Helper function to create parent directories recursively ;;; Helper function to create parent directories recursively
(define (mkdir-p path) (define (mkdir-p path)
"Create directory and parent directories if they don't exist." "Create directory and parent directories if they don't exist."
(display (format #f "Creating parent directory: ~a\n" path)) (let ((real-path (if (package? path)
(let ((parent (dirname path))) (package-source path)
(when (not (file-exists? parent)) path)))
(mkdir-p parent)) (display (format #f "Creating parent directory: ~a\n" real-path))
(when (not (file-exists? path)) (let ((parent (dirname real-path)))
(mkdir path #o755)))) (when (not (file-exists? parent))
(mkdir-p parent))
(when (not (file-exists? real-path))
(mkdir real-path #o755)))))
;;; Helper function to execute operations ;;; Helper function to execute operations
(define (execute-operations operations) (define (execute-operations operations)
@ -115,46 +162,79 @@
(define (ensure-directory dir) (define (ensure-directory dir)
"Create directory if it doesn't exist" "Create directory if it doesn't exist"
(when (not (file-exists? dir)) (let ((real-dir (if (package? dir)
(mkdir-p dir))) (package-source dir)
dir)))
(when (not (file-exists? real-dir))
(mkdir-p real-dir))))
(define (copy-recursive source target) (define (copy-recursive source target)
"Copy directory recursively" "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) (define (delete-recursive path)
"Delete file or directory recursively" "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) (define (make-file-executable path)
"Make file executable" "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) (define (make-file-readable path)
"Make file readable" "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) (define (file-is-executable? path)
"Check if file is executable" "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))))) (not (zero? (logand mode execute-permission)))))
(define (file-is-readable? path) (define (file-is-readable? path)
"Check if file is readable" "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))))) (not (zero? (logand mode read-permission)))))
(define (resolve-symlink path) (define (resolve-symlink path)
"Resolve symlink to its target" "Resolve symlink to its target"
(if (file-is-symlink? path) (let ((real-path (if (package? path)
(readlink path) (package-source path)
path)) path)))
(if (file-is-symlink? real-path)
(readlink real-path)
real-path)))
(define (update-symlink target link) (define (update-symlink target link)
"Update or create symlink" "Update or create symlink"
(when (file-exists? link) (let ((real-target (if (package? target)
(delete-file link)) (package-source target)
(symlink target link)) 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 list
(export mkdir-p (export mkdir-p

22
modules/stash/paths.scm
View File

@ -2,6 +2,7 @@
(define-module (stash paths) (define-module (stash paths)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (srfi srfi-1) ; For drop
#:export (expand-home #:export (expand-home
normalize-path normalize-path
relative-path relative-path
@ -28,7 +29,8 @@
(let ((target-dir (expand-home target-dir))) (let ((target-dir (expand-home target-dir)))
(if (string-suffix? "/" target-dir) (if (string-suffix? "/" target-dir)
(set! target-dir (string-drop-right target-dir 1))) ;; Remove trailing slash if it exists (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") (string-append target-dir "/.config")
target-dir))) target-dir)))
@ -71,12 +73,12 @@
(string=? (list-ref base-parts i) (string=? (list-ref base-parts i)
(list-ref target-parts i))) (list-ref target-parts i)))
(loop (+ i 1)) (loop (+ i 1))
i))) i))))
(up-count (- (length base-parts) common-prefix-length)) ;; Drop common prefix from both paths
(down-parts (list-tail target-parts common-prefix-length))) (let* ((base-unique (drop base-parts common-prefix-length))
(if (and (= up-count 0) (null? down-parts)) (target-unique (drop target-parts common-prefix-length))
"." (up-dirs (make-list (length base-unique) ".."))
(string-join (relative-parts (append up-dirs target-unique)))
(append (make-list up-count "..") (if (null? relative-parts)
down-parts) "."
"/")))) (string-join relative-parts "/")))))

94
modules/stash/tree.scm
View File

@ -6,6 +6,7 @@
#:use-module (stash file-ops) #:use-module (stash file-ops)
#:use-module (stash log) #:use-module (stash log)
#:use-module (stash paths) #:use-module (stash paths)
#:use-module (stash package) ; For package record type
#:export (analyze-tree #:export (analyze-tree
fold-tree fold-tree
plan-operations plan-operations
@ -16,7 +17,8 @@
(ice-9 regex) (ice-9 regex)
(srfi srfi-1) (srfi srfi-1)
(stash file-ops) (stash file-ops)
(stash paths)) (stash paths)
(stash package))
;; Tree node record type ;; Tree node record type
(define-record-type <tree-node> (define-record-type <tree-node>
@ -27,26 +29,34 @@
(children node-children)) (children node-children))
;; Analyze directory tree and create tree structure ;; Analyze directory tree and create tree structure
(define* (analyze-tree root-path #:optional (ignore-patterns '())) (define (analyze-tree input)
(let analyze ((path root-path)) "Create a tree structure from a directory path or package.
(cond If input is a package, uses package-source and package ignores.
((file-is-symlink? path) If input is a string, treats it as a path with no ignores."
(make-tree-node path 'symlink '())) (let* ((path (if (package? input)
((file-is-directory? path) (package-source input)
(let* ((entries (scandir path)) input))
(children (filter-map (should-include? (if (package? input)
(lambda (entry) (lambda (file-path)
(if (or (member entry '("." "..")) (should-include-file? input file-path))
(and (not (null? ignore-patterns)) (lambda (file-path) #t))))
(any (lambda (pattern) (let analyze ((path path))
(string-match pattern entry)) (cond
ignore-patterns))) ((file-is-symlink? path)
#f (make-tree-node path 'symlink '()))
(analyze (string-append path "/" entry)))) ((file-is-directory? path)
entries))) (let* ((entries (scandir path))
(make-tree-node path 'directory children))) (children (filter-map
(else (lambda (entry)
(make-tree-node path 'file '()))))) (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 ;; Fold over a tree structure
(define (fold-tree proc init tree) (define (fold-tree proc init tree)
@ -81,21 +91,27 @@
(check-children (cdr children)))))))) (check-children (cdr children))))))))
;; Plan stow operations for a tree ;; Plan stow operations for a tree
(define (plan-operations tree target-dir) (define (plan-operations tree target)
(let ((source-base (node-path tree))) "Plan operations for stowing files. Target can be either a string path or a package."
(fold-tree (let* ((target-dir (if (package? target)
(lambda (node acc) (package-target target)
(let* ((relative-path (relative-path source-base (node-path node))) target))
(target-path (string-append target-dir "/" relative-path))) (source-base (node-path tree)))
(cond ;; First move the source directory to target
((eq? (node-type node) 'directory) (cons `(move ,source-base ,target-dir)
(if (not (file-exists? target-path)) (fold-tree
(cons `(mkdir ,target-path) acc) (lambda (node acc)
acc)) (let* ((relative-path (relative-path source-base (node-path node)))
((eq? (node-type node) 'file) (target-path (string-append target-dir "/" relative-path))
(if (not (file-exists? target-path)) (source-path (node-path node)))
(cons `(symlink ,(node-path node) ,target-path) acc) (cond
acc)) ((eq? (node-type node) 'directory)
(else acc)))) (if (not (file-exists? target-path))
'() (cons `(mkdir ,target-path) acc)
tree))) 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))))

9
stash.scm Normal file → Executable file
View File

@ -46,13 +46,14 @@
(define (handle-explicit-stash source target recursive?) (define (handle-explicit-stash source target recursive?)
"Handle stashing with explicit source and target paths." "Handle stashing with explicit source and target paths."
(let* ((source-path (canonicalize-path source)) (let* ((source-path (normalize-path source))
(target-path (canonicalize-path target)) (target-path (normalize-path target))
(package-name (basename source-path)) (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? (if recursive?
(handle-recursive-stash source-path target-path) (handle-recursive-stash source-path target-path)
(let ((package (make-package package-name source-path target-path ignore-patterns))) (begin
(process-package package) (process-package package)
#t)))) #t))))

14
tests/tree-test.scm
View File

@ -38,6 +38,15 @@
;; Test operation planning ;; Test operation planning
(let* ((tree (scan-directory source-dir)) (let* ((tree (scan-directory source-dir))
(ops (plan-operations tree target-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" (test-assert "Should plan to create target directory"
(any (lambda (op) (any (lambda (op)
(and (eq? (car op) 'mkdir) (and (eq? (car op) 'mkdir)
@ -45,11 +54,14 @@
(string-append target-dir "/dir")))) (string-append target-dir "/dir"))))
ops)) ops))
;; Should create symlinks in source pointing to target
(test-assert "Should plan to create symlinks" (test-assert "Should plan to create symlinks"
(any (lambda (op) (any (lambda (op)
(and (eq? (car op) 'symlink) (and (eq? (car op) 'symlink)
(string=? (cadr op)
(string-append target-dir "/config.txt"))
(string=? (caddr op) (string=? (caddr op)
(string-append target-dir "/config.txt")))) (string-append source-dir "/config.txt"))))
ops)))))) ops))))))
(test-end "tree") (test-end "tree")