From 14b20d602883f336aa6a4474619f188588aff1f2 Mon Sep 17 00:00:00 2001 From: GLENN THOMPSON Date: Fri, 6 Dec 2024 19:31:47 +0300 Subject: [PATCH] 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 --- modules/stash/file-ops.scm | 178 +++++++++++++++++++++++++++---------- modules/stash/paths.scm | 22 ++--- modules/stash/tree.scm | 94 ++++++++++++-------- stash.scm | 9 +- tests/tree-test.scm | 14 ++- 5 files changed, 214 insertions(+), 103 deletions(-) mode change 100644 => 100755 stash.scm diff --git a/modules/stash/file-ops.scm b/modules/stash/file-ops.scm index 0364acd..d4797ba 100644 --- a/modules/stash/file-ops.scm +++ b/modules/stash/file-ops.scm @@ -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 diff --git a/modules/stash/paths.scm b/modules/stash/paths.scm index 0d2d4ce..b3884f6 100644 --- a/modules/stash/paths.scm +++ b/modules/stash/paths.scm @@ -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 "/"))))) diff --git a/modules/stash/tree.scm b/modules/stash/tree.scm index 205cb3b..81b1097 100644 --- a/modules/stash/tree.scm +++ b/modules/stash/tree.scm @@ -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 @@ -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)))) diff --git a/stash.scm b/stash.scm old mode 100644 new mode 100755 index be7aece..3a74729 --- a/stash.scm +++ b/stash.scm @@ -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)))) diff --git a/tests/tree-test.scm b/tests/tree-test.scm index 7be7259..31d2e89 100644 --- a/tests/tree-test.scm +++ b/tests/tree-test.scm @@ -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")