stash/guile-stash.scm

;;; guile-stash.scm --- A Guile script for creating and managing symlinks with conflict resolution
;;;
;;; Author: Glenn Thompson <glenn@kirstol.org>
;;; Version: 1.1
;;; Created: 2024-12-03
;;; Compatibility: Guile 3.0.9
;;; Keywords: symlink, file management, conflict resolution
;;;
;;; Commentary:
;;;
;;; Guile-Stash is a command-line utility written in Guile Scheme designed to facilitate the creation of symbolic links (symlinks)
;;; for files and directories. It allows users to specify a source file or directory and a target directory where the symlink(s)
;;; should be created. The utility handles potential conflicts with existing files or directories at the target location,
;;; offering users the choice to overwrite 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 or skip).
;;; - Support for symlinking both files and directories.
;;; - Simple and interactive user interface for easy use.
;;;
;;; Usage:
;;;
;;; guile -L . guile-stash.scm --target=<target-dir> --package-dir=<package-dir>
;;;
;;; Replace <target-dir> with the directory where you want the symlink(s) to be created,
;;; and <package-dir> with the path to the source file or directory.
;;;
;;; License:
;;;
;;; ;;; guile-stash.scm --- Description of the script
;;;
;;; Copyright (c) 2024 Glenn Thompson
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.
;;;
;;; For the full license text, see the LICENSE file.

;;; Code:

;; TODO: Refactor Repeated Logic: The logic for checking if a path is a file or directory and appending the basename is repeated in the create-symlink function. This could be encapsulatedin a helper function to improve readability and avoid redundancy. e.g.

;; (define (build-target-path source target)
;;   (string-append target "/" (basename source)))

;; TODO: Modularize Conflict Handling: Separating conflict handling into its own module to keep the main functionality more focused. This will also help to extend the conflict resolution mechanism with more options (e.g., backup, replace).

;; TODO: Add Logging Capabilities: It might be useful to log actions like creating symlinks, skipping conflicts, or canceling operations to a file for auditing purposes. Adding a logging function that appends these actions to a log file. e.g.

;; (define (log-action message)
;;   (with-output-to-file "guile-stash.log"
;;     (lambda () (display message) (newline))
;;     #:append #t))

;; TODO: Improve Error Handling: While catch is used, it's broad and might not capture the exact error. Using more specific error types (like system-error and file-error) could improve the granularity of error reporting. Additionally, return appropriate exit codes for different failure conditions to support integration with other scripts.

;; TODO: Optimize the delete-directory Function: Using rm -r is risky for recursive deletion in case of directory traversal attacks. You could implement a Scheme-native recursive delete function to avoid this.

;; #TODO Addition of a Non-Interactive Mode: Adding a non-interactive mode that automatically skips or overwrites conflicts (based on a command-line flag) could make the script more flexible for use in automation workflows. e.g.

;; (define (parse-arguments args)
;;   (let* ((opts (getopt-long args
;;                             '((target (value #t) (required? #t))
;;                               (package-dir (value #t) (required? #t))
;;                               (non-interactive (value #f) (default #f))))))
;;     opts))

;; TODO: Refactor Command-Line Parsing: The current command-line argument parsing could be expanded to handle other optional flags more easily. e.g., adding help or verbose flags to improve user interaction.

;; TODO: Check for Broken Symlinks: Before deciding to overwrite a symlink, check if the existing symlink is broken, and handle it appropriately. e.g.

    ;; (define (symlink-broken? path)
    ;;   (and (file-is-symlink? path) (not (file-exists? path))))

;; These changes will make the script more maintainable, secure, and flexible for future development.

;; Import necessary modules
(use-modules (ice-9 getopt-long)
             (ice-9 popen)  ;; Additional module for executing system commands
             (ice-9 rdelim))

;;; 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))

(define (shell-quote-argument arg)
  (if (string-contains arg " ")
      (string-append "\"" (string-replace arg "\"" "\\\"") "\"")
      arg))

(define (parse-arguments args)
  "Parse command-line arguments."
  (let* ((opts (getopt-long args
                            '((target (value #t) (required? #t))
                              (package-dir (value #t) (required? #t))))))
    opts))

(define (delete-directory path)
  (if (file-is-directory? path)
      (begin
        (system (string-append "rm -r " (shell-quote-argument path)))
        #t)
      #f))

(define (prompt-user-for-action)
  "Prompt the user to decide how to handle a conflict: overwrite (o), skip (s), or cancel (c)."
  (display (color-message "A conflict was detected. Choose action - Overwrite (o), Skip (s), or Cancel (c): " yellow-text))
  (let ((response (read-line)))
    (cond
      ((string-ci=? response "o") 'overwrite)
      ((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-action))))) ; Recursive call on invalid input.

(define (file-is-symlink? path)
  ;; Use lstat to check if the file is a symbolic link without following it
  (let ((stat (lstat path)))
    (eqv? (stat:type stat) 'symlink)))

(define (create-symlink source target)
  "Create a symlink for the source file or directory at the target location."
  ;; Determine whether source is a file or directory and adjust the target path accordingly.
  (let ((target-symlink-path
         (if (file-is-directory? source)
             (string-append target "/" (basename source))  ;; If it's a directory, append the directory name to the target
             (string-append target "/" (basename source))))) ;; If it's a file, append the file name to the target
    (if (file-exists? target-symlink-path)
        (handle-conflicts source target-symlink-path) ; Call conflict handler if symlink already exists
        (catch 'system-error
          (lambda ()
            (symlink source target-symlink-path)
            (display (color-message (format #f "Symlink created: ~a -> ~a\n" target-symlink-path source) green-text)))
          (lambda args
            (display (color-message "Error creating symlink.\n" red-text)))))))

(define (handle-conflicts source target)
  ;; Display the conflict message in yellow (warning).
  (display (color-message (format #f "Conflict detected! A symbolic link already exists at ~a.\n" target) yellow-text))
  (let ((choice (prompt-user-for-action))) ;; Call the updated prompt-user-for-action
    (cond
      ((eq? choice 'overwrite)
       ;; Check if the target is a symlink, and remove the symlink (not the directory it points to).
       (if (file-is-symlink? target)
           (begin
             (delete-file target) ;; Safely delete the symlink.
             (display (color-message "Removed the existing symbolic link.\n" green-text))
             ;; Now, recreate the symlink after removing the old one
             (create-symlink source (dirname target)))
           (display (color-message "Error: Target is not a symbolic link.\n" red-text))))
      ((eq? choice 'skip)
       ;; Do nothing; keep the existing symbolic link.
       (display (color-message "Keeping existing symbolic link.\n" green-text)))
      ((eq? choice 'cancel)
       ;; Cancel the operation and exit
       (display (color-message "Operation cancelled.\n" yellow-text))
       (exit 0))
      (else
       ;; Invalid input (this should never happen because prompt-user-for-action handles it).
       (display (color-message "Invalid choice. Please try again.\n" red-text))
       (handle-conflicts source target)))))

(define (main args)
  "Main function to parse arguments and initiate processing."
  (setenv "GUILE_AUTO_COMPILE" "0")
  (let* ((options (parse-arguments args))
         (target-dir (assoc-ref options 'target))
         (package-dir (assoc-ref options 'package-dir)))
    (if (and target-dir package-dir)
        (catch 'symlink-error
          (lambda ()
            (create-symlink package-dir target-dir)) ;; Try to create symlink
          (lambda (key . args)
            ;; Handle the 'symlink-error
            (display (color-message (format #f "Error creating symlink: ~a\n" (car args)) red-text))))
        (begin
          (display (color-message "Error: Missing required arguments.\n" red-text))
          (display (color-message "Usage: guile stash.scm --target=<target-dir> --package-dir=<package-dir>\n" yellow-text))
          (exit 1)))))

;; Entry point for guile-stash
(main (command-line))