mirror of https://codeberg.org/glenneth/stash.git
224 lines
11 KiB
Scheme
224 lines
11 KiB
Scheme
;;; stash.scm --- A Guile script for moving directories and creating symlinks with conflict resolution
|
|
;;;
|
|
;;; Author: Glenn Thompson <glenn@kirstol.org>
|
|
;;; Version: 0.1.0-alpha.1
|
|
;;; Created: 2024-12-03
|
|
;;; Compatibility: Guile 3.0.9
|
|
;;; Keywords: symlink, file management, conflict resolution, backup
|
|
;;;
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Stash is a command-line utility written in Guile Scheme designed to facilitate the movement of directories and
|
|
;;; creation of symbolic links (symlinks) for files and directories. It allows users to specify a source directory
|
|
;;; and a target directory where the symlink should be created. The utility handles potential conflicts with existing
|
|
;;; files or directories at the target location, offering users the choice to overwrite, back up, or skip the creation of new symlinks.
|
|
;;;
|
|
;;; Main Features:
|
|
;;; - Command-line argument parsing for specifying source and target paths.
|
|
;;; - Conflict detection with interactive user resolution options (overwrite, backup, skip, or cancel).
|
|
;;; - Moving directories and creating symlinks.
|
|
;;; - Simple and interactive user interface for easy use.
|
|
;;;
|
|
;;; Usage:
|
|
;;;
|
|
;;; guile -L . stash.scm --target=<target-dir> --source=<source-dir>
|
|
;;;
|
|
;;; Replace <target-dir> with the directory where you want the symlink to be created,
|
|
;;; and <source-dir> with the path to the source directory.
|
|
;;;
|
|
;;; License:
|
|
;;;
|
|
;;; This project is licensed under the GNU General Public License v3.
|
|
;;;
|
|
;;; Code:
|
|
|
|
;; Import necessary modules
|
|
(use-modules (ice-9 getopt-long)
|
|
(ice-9 popen)
|
|
(ice-9 rdelim)
|
|
(ice-9 format)
|
|
(srfi srfi-1)
|
|
(srfi srfi-19)) ;; Use for list handling and date-time formatting
|
|
|
|
;;; ANSI Color Codes for terminal output
|
|
(define red-text "\x1b[31m")
|
|
(define yellow-text "\x1b[33m")
|
|
(define green-text "\x1b[32m")
|
|
(define reset-text "\x1b[0m")
|
|
|
|
;;; Function to wrap messages in color
|
|
(define (color-message message color)
|
|
(string-append color message reset-text))
|
|
|
|
;;; Helper function to get a formatted current time string
|
|
(define (current-timestamp)
|
|
"Return the current date and time as a formatted string."
|
|
(let* ((time (current-time))
|
|
(seconds (time-second time)))
|
|
(strftime "%Y-%m-%d-%H-%M-%S" (localtime seconds))))
|
|
|
|
;;; Improved logging function with timestamp
|
|
(define (log-action message)
|
|
"Log an action with a timestamp to the stash.log file."
|
|
(let ((log-port (open-file "stash.log" "a"))) ;; Open file in append mode
|
|
(display (string-append "[" (current-timestamp) "] " message) log-port)
|
|
(newline log-port)
|
|
(close-port log-port))) ;; Close the port after writing
|
|
|
|
;;; Expand ~ in paths to the full home directory path
|
|
(define (expand-home path)
|
|
"Expand ~ to the user's home directory."
|
|
(if (string-prefix? "~" path)
|
|
(string-append (getenv "HOME") (substring path 1))
|
|
path))
|
|
|
|
;;; Helper function to back up a directory or symlink
|
|
(define (backup-path path)
|
|
"Back up a directory or symlink by renaming it with a timestamp."
|
|
(let ((backup-path (string-append path ".backup." (current-timestamp))))
|
|
(rename-file path backup-path)
|
|
(display (color-message (format #f "Backed up ~a to ~a\n" path backup-path) green-text))
|
|
(log-action (format #f "Backed up ~a to ~a" path backup-path))))
|
|
|
|
;;; Function to handle command-line arguments
|
|
(define (parse-arguments args)
|
|
"Parse command-line arguments."
|
|
(let* ((opts (getopt-long args
|
|
'((target (value #t) (required? #t))
|
|
(source (value #t) (required? #t))))))
|
|
opts))
|
|
|
|
;;; Helper function to quote shell arguments
|
|
(define (shell-quote-argument arg)
|
|
"Quote shell argument to handle spaces or special characters."
|
|
(if (string-contains arg " ")
|
|
(string-append "\"" (string-replace arg "\"" "\\\"") "\"")
|
|
arg))
|
|
|
|
;;; 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))) ;; Use rm -rf to delete recursively
|
|
(log-action (format #f "Deleted directory: ~a" path))) ;; Log the deletion
|
|
(display (color-message "Error: Path is not a directory.\n" red-text))))
|
|
|
|
;;; 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."
|
|
(let* ((source-dir (expand-home source-dir))
|
|
(target-dir (expand-home target-dir))
|
|
(source-name (basename source-dir))
|
|
(target-source-dir (string-append target-dir "/" source-name)))
|
|
;; Check if the target directory already exists
|
|
(if (file-exists? target-source-dir)
|
|
(begin
|
|
(display (color-message (format #f "Directory ~a already exists.\n" target-source-dir) yellow-text))
|
|
;; Handle the conflict: overwrite, backup, or skip
|
|
(let ((choice (prompt-user-for-backup-action)))
|
|
(cond
|
|
((eq? choice 'overwrite)
|
|
(delete-directory target-source-dir)
|
|
(rename-file source-dir target-source-dir)
|
|
(display (color-message (format #f "Overwriting directory ~a.\n" target-source-dir) green-text))
|
|
(log-action (format #f "Overwritten directory: ~a" target-source-dir)))
|
|
((eq? choice 'backup)
|
|
(backup-path target-source-dir)
|
|
(rename-file source-dir target-source-dir)
|
|
(display (color-message (format #f "Moved ~a to ~a\n" source-dir target-source-dir) green-text))
|
|
(log-action (format #f "Moved ~a to ~a after backup" source-dir target-source-dir)))
|
|
((eq? choice 'skip)
|
|
(display (color-message "Skipping move operation.\n" green-text))
|
|
(log-action (format #f "Skipped moving directory: ~a" target-source-dir)))
|
|
((eq? choice 'cancel)
|
|
(display (color-message "Operation cancelled by user.\n" yellow-text))
|
|
(log-action "Operation cancelled by user.")
|
|
(exit 0)))))
|
|
;; If the target directory doesn't exist, proceed with the move
|
|
(begin
|
|
(rename-file source-dir target-source-dir)
|
|
(display (color-message (format #f "Moved ~a to ~a\n" source-dir target-source-dir) green-text))
|
|
(log-action (format #f "Moved ~a to ~a" source-dir target-source-dir))))
|
|
target-source-dir)) ;; Return the path of the moved source directory
|
|
|
|
;;; Helper function to create a symlink in the parent directory of the original source
|
|
(define (create-symlink-in-parent source-dir target-dir)
|
|
"Create a symlink in the parent directory of source-dir."
|
|
(let* ((parent-dir (expand-home (dirname source-dir))) ;; Ensure the parent path is expanded
|
|
(symlink-target (string-append parent-dir "/" (basename source-dir)))
|
|
(target-dir (expand-home target-dir))) ;; Ensure the target path is expanded
|
|
;; Check if symlink already exists
|
|
(if (file-exists? symlink-target)
|
|
(handle-conflicts source-dir symlink-target) ;; Handle conflict if symlink or file exists
|
|
(begin
|
|
;; Create the symlink if no conflict
|
|
(symlink target-dir symlink-target)
|
|
(display (color-message (format #f "Symlink created at ~a pointing to ~a\n" symlink-target target-dir) green-text))
|
|
(log-action (format #f "Symlink created at ~a pointing to ~a" symlink-target target-dir))))))
|
|
|
|
;;; Conflict resolution handler with backup option
|
|
(define (prompt-user-for-backup-action)
|
|
"Prompt the user to decide how to handle a conflict: overwrite (o), backup (b), skip (s), or cancel (c)."
|
|
(display (color-message "A conflict was detected. Choose action - Overwrite (o), Backup (b), Skip (s), or Cancel (c): " yellow-text))
|
|
(let ((response (read-line)))
|
|
(cond
|
|
((string-ci=? response "o") 'overwrite)
|
|
((string-ci=? response "b") 'backup)
|
|
((string-ci=? response "s") 'skip)
|
|
((string-ci=? response "c") 'cancel)
|
|
(else
|
|
(display (color-message "Invalid input. Please try again.\n" red-text))
|
|
(prompt-user-for-backup-action)))))
|
|
|
|
;;; Function to handle conflicts with symlinks and directories
|
|
(define (handle-conflicts source target)
|
|
"Handle conflicts when a symlink or file already exists at the target location."
|
|
(display (color-message (format #f "Conflict detected! A file or symlink already exists at ~a.\n" target) yellow-text))
|
|
(let ((choice (prompt-user-for-backup-action))) ;; Prompt for backup or overwrite
|
|
(cond
|
|
((eq? choice 'overwrite)
|
|
(if (file-is-symlink? target)
|
|
(begin
|
|
(delete-file target)
|
|
(display (color-message "Removed the existing symbolic link.\n" green-text))
|
|
(log-action (format #f "Removed the existing symbolic link at ~a" target))
|
|
(create-symlink-in-parent source target))
|
|
(display (color-message "Error: Target is not a symbolic link.\n" red-text))))
|
|
((eq? choice 'backup)
|
|
(backup-path target) ;; Backup the existing directory or symlink
|
|
(create-symlink-in-parent source target)) ;; After backup, create the new symlink
|
|
((eq? choice 'skip)
|
|
(log-action (format #f "Skipped creating symlink at ~a" target))
|
|
(display (color-message "Keeping existing symbolic link.\n" green-text)))
|
|
((eq? choice 'cancel)
|
|
(log-action "Operation cancelled by user.")
|
|
(display (color-message "Operation cancelled.\n" yellow-text))
|
|
(exit 0))
|
|
(else
|
|
(display (color-message "Invalid choice. Please try again.\n" red-text))
|
|
(handle-conflicts source target)))))
|
|
|
|
;;; Main function to handle source and target operations
|
|
(define (handle-source-and-target source-dir target-dir)
|
|
"Move the source directory to the target and create a symlink in the parent directory."
|
|
(let ((target-source-dir (move-source-to-target source-dir target-dir))) ;; Move the directory
|
|
(create-symlink-in-parent source-dir target-source-dir))) ;; Create the symlink if no conflict
|
|
|
|
;;; Main entry point
|
|
(define (main args)
|
|
"Main function to parse arguments and execute the program."
|
|
(setenv "GUILE_AUTO_COMPILE" "0") ;; Disable auto-compilation to improve performance
|
|
(let* ((options (parse-arguments args))
|
|
(target-dir (assoc-ref options 'target))
|
|
(source-dir (assoc-ref options 'source)))
|
|
(if (and target-dir source-dir)
|
|
(handle-source-and-target source-dir target-dir) ;; Handle the source move and symlink creation
|
|
(begin
|
|
(display (color-message "Error: Missing required arguments.\n" red-text))
|
|
(display (color-message "Usage: stash.scm --target=<target-dir> --source=<source-dir>\n" yellow-text))
|
|
(exit 1)))))
|
|
|
|
;; Entry point for stash
|
|
(main (command-line))
|