From ef33eefa4cc45f2d80d7ffe27080bf766e9fa999 Mon Sep 17 00:00:00 2001 From: Craig Jennings Date: Sat, 6 Jun 2026 11:34:24 -0500 Subject: feat: add the pure data-safety planner Phase 3 shipped conflict and move sequencing but skipped the data-safety checks the design spec makes the pure planner's job. This adds them: same-file rejection, dir-into-itself rejection, trailing-slash destination resolution, special-file rejection, symlink surfacing, case-insensitive collision detection, and path-length and reserved-name checks. Every check is pure. The filesystem facts each one needs (a path's lstat type, the names already at a destination, whether that filesystem folds case, its path-length limit, its reserved names) are injected, so the planner decides before a byte moves and the tests never touch a real file. Each problem is a plist with a class, a severity, the file, and a message. An error severity blocks a transfer, and a warning surfaces a decision, which is how a symlink is carried as follow-versus-preserve rather than silently chosen. duet--plan-move-safe composes the checks with the move planner: a source carrying a blocking error is skipped with no copy and no delete, a safe source gets a copy and a delete gated on its copy success, and no delete is ever ungated. Coverage on duet.el rises to 92.3%. --- duet.el | 135 ++++++++++++++++++++++++++++++++++++++++++++ tests/test-duet-safety.el | 141 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 276 insertions(+) create mode 100644 tests/test-duet-safety.el diff --git a/duet.el b/duet.el index 1fe3d31..b546264 100644 --- a/duet.el +++ b/duet.el @@ -586,6 +586,141 @@ confirmed. Return a flat list of step plists in execution order." (list :op 'delete :source s :gate 'copy-success))) sources))) +;;; Data-safety planning (pure, prompt-free) + +;; The category's recurring data-loss traps are decided here, before any byte +;; moves. Every check is pure: filesystem facts (a path's lstat type, the +;; names already at a destination, whether the destination filesystem folds +;; case, its path-length limit, its reserved names) are injected, so the +;; planner is testable without touching a file. Each problem is a plist +;; (:class :severity :file :message); `error' severity blocks, `warning' +;; surfaces a decision (follow-vs-preserve a symlink). + +(defun duet--norm (path) + "Lexically normalize PATH: expand it and strip a trailing slash." + (directory-file-name (expand-file-name path))) + +(defun duet--trailing-slash-p (path) + "Return non-nil when PATH ends with a slash." + (and (> (length path) 0) + (eq (aref path (1- (length path))) ?/))) + +(defun duet--check-same-file (source destination) + "Flag a transfer whose SOURCE and DESTINATION are the same file." + (when (string= (duet--norm source) (duet--norm destination)) + (list :class 'same-file :severity 'error :file source + :message "Source and destination are the same file."))) + +(defun duet--check-dir-into-itself (source destination) + "Flag a transfer whose DESTINATION is inside the SOURCE directory." + (let ((s (file-name-as-directory (duet--norm source))) + (d (file-name-as-directory (duet--norm destination)))) + (when (and (not (string= s d)) + (string-prefix-p s d)) + (list :class 'destination-within-source :severity 'error :file destination + :message "The destination is inside the source directory.")))) + +(defun duet--resolved-destination (source destination-directory) + "Return the path SOURCE lands at when copied into DESTINATION-DIRECTORY. +A SOURCE with a trailing slash copies its contents, landing in the +destination directory itself; without one, SOURCE lands as a named child. +Making the resolved path explicit defuses the trailing-slash \"into vs +contents\" footgun." + (let ((dest (file-name-as-directory (expand-file-name destination-directory)))) + (if (duet--trailing-slash-p source) + (directory-file-name dest) + (concat dest (file-name-nondirectory (duet--norm source)))))) + +(defun duet--check-special-file (path type) + "Flag PATH when its lstat TYPE is a device/fifo/socket DUET will not transfer. +TYPE is a symbol from an lstat-based classifier: `file', `directory', +`symlink', or a special type; nil means the type is unknown. Regular files, +directories, symlinks, and unknown types are allowed." + (unless (memq type '(file directory symlink nil)) + (list :class 'unsupported-special-file :severity 'error :file path + :message (format "%s is a special file (%s) DUET will not transfer." + path type)))) + +(defun duet--check-symlink (path type) + "Surface PATH as a warning when its lstat TYPE is a symlink. +A symlink is transferable, but follow-versus-preserve is a decision the user +must make, so it is surfaced rather than silently chosen." + (when (eq type 'symlink) + (list :class 'symlink :severity 'warning :file path + :message "Source is a symlink; choose follow or preserve before transfer."))) + +(defun duet--check-case-collision (destination existing-names case-insensitive) + "Flag a case-only collision at DESTINATION on a case-insensitive filesystem. +EXISTING-NAMES are the basenames already at the destination directory, and +CASE-INSENSITIVE says whether that filesystem folds case. An exact match is +an ordinary conflict, not a case collision, so it is not flagged here." + (when case-insensitive + (let ((base (file-name-nondirectory (duet--norm destination)))) + (when (cl-some (lambda (n) + (and (not (string= n base)) + (string-equal-ignore-case n base))) + existing-names) + (list :class 'case-collision :severity 'error :file destination + :message (format "%s collides with an existing name by case only." + base)))))) + +(defun duet--check-path-length (destination max-length) + "Flag DESTINATION when it is longer than MAX-LENGTH. +MAX-LENGTH is the destination filesystem's limit, or nil when unknown." + (when (and max-length (> (length destination) max-length)) + (list :class 'path-too-long :severity 'error :file destination + :message (format "Destination path is %d chars; the limit is %d." + (length destination) max-length)))) + +(defun duet--check-reserved-name (destination reserved-p) + "Flag DESTINATION when its basename is reserved on the target filesystem. +RESERVED-P is a predicate called with the basename, or nil when the +destination has no reserved names." + (let ((base (file-name-nondirectory (duet--norm destination)))) + (when (and reserved-p (funcall reserved-p base)) + (list :class 'reserved-name :severity 'error :file destination + :message (format "%s is a reserved name on the destination." base))))) + +(defun duet--plan-safety (source destination &optional caps) + "Return the data-safety problems for moving SOURCE to DESTINATION. +Pure: every filesystem fact comes from CAPS, so no file is touched. CAPS +keys: :file-type (fn PATH -> lstat type symbol), :existing-names (fn DEST -> +basenames), :case-insensitive (fn DEST -> bool), :max-path-length (int), and +:reserved-name (fn BASENAME -> bool). Each problem is a plist +\(:class :severity :file :message)." + (let ((type (let ((f (plist-get caps :file-type))) (and f (funcall f source)))) + (existing (let ((f (plist-get caps :existing-names))) (and f (funcall f destination)))) + (ci (let ((f (plist-get caps :case-insensitive))) (and f (funcall f destination))))) + (delq nil + (list (duet--check-same-file source destination) + (duet--check-dir-into-itself source destination) + (duet--check-special-file source type) + (duet--check-symlink source type) + (duet--check-case-collision destination existing ci) + (duet--check-path-length destination (plist-get caps :max-path-length)) + (duet--check-reserved-name destination (plist-get caps :reserved-name)))))) + +(defun duet--plan-move-safe (sources destination-directory &optional caps) + "Return a move plan for SOURCES into DESTINATION-DIRECTORY with safety gating. +Each source is resolved to its destination and run through `duet--plan-safety' +with CAPS. A source carrying a blocking (`error' severity) problem is skipped +\(no copy, no delete) as an :op skip recording its :problems; a safe source +gets a copy followed by a delete gated on copy success. No delete is ever +ungated." + (apply #'append + (mapcar + (lambda (s) + (let* ((dest (duet--resolved-destination s destination-directory)) + (problems (duet--plan-safety s dest caps)) + (errors (cl-remove-if-not + (lambda (p) (eq 'error (plist-get p :severity))) + problems))) + (if errors + (list (list :op 'skip :source s :destination dest :problems problems)) + (list (list :op 'copy :source s :destination dest :problems problems) + (list :op 'delete :source s :gate 'copy-success))))) + sources))) + ;;;###autoload (defun duet () "Launch the DUET dual-pane file commander." diff --git a/tests/test-duet-safety.el b/tests/test-duet-safety.el new file mode 100644 index 0000000..450a8ea --- /dev/null +++ b/tests/test-duet-safety.el @@ -0,0 +1,141 @@ +;;; test-duet-safety.el --- Tests for the data-safety planner -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Tests for the pure data-safety planner: same-file and dir-into-itself +;; rejection, trailing-slash destination resolution, symlink/special-file +;; surfacing, case-insensitive collision detection, path-length and +;; reserved-name checks, and the safety-composed move planner. Every +;; filesystem fact is injected, so no test touches a real file. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;;; same-file + +(ert-deftest test-duet-safety-same-file-rejected () + (should (eq 'same-file (plist-get (duet--check-same-file "/a/b" "/a/b") :class))) + (should (eq 'same-file (plist-get (duet--check-same-file "/a/b/" "/a/b") :class))) + (should (null (duet--check-same-file "/a/b" "/a/c")))) + +;;; dir-into-itself + +(ert-deftest test-duet-safety-dir-into-itself-rejected () + (should (eq 'destination-within-source + (plist-get (duet--check-dir-into-itself "/a/b" "/a/b/sub") :class))) + (should (null (duet--check-dir-into-itself "/a/b" "/a/c"))) + ;; a sibling whose name merely shares a prefix is not "inside" + (should (null (duet--check-dir-into-itself "/a/b" "/a/bc")))) + +;;; trailing-slash resolution + +(ert-deftest test-duet-safety-resolved-destination () + (should (equal "/c/b" (duet--resolved-destination "/a/b" "/c"))) + (should (equal "/c/b" (duet--resolved-destination "/a/b" "/c/"))) + ;; a trailing slash on the source means "copy contents", landing in /c itself + (should (equal "/c" (duet--resolved-destination "/a/b/" "/c")))) + +;;; special files and symlinks + +(ert-deftest test-duet-safety-special-file-rejected () + (should (eq 'unsupported-special-file + (plist-get (duet--check-special-file "/dev/fifo" 'fifo) :class))) + (should (null (duet--check-special-file "/a/f" 'file))) + (should (null (duet--check-special-file "/a/d" 'directory))) + (should (null (duet--check-special-file "/a/l" 'symlink))) + (should (null (duet--check-special-file "/a/x" nil)))) + +(ert-deftest test-duet-safety-symlink-surfaced-as-warning () + (let ((p (duet--check-symlink "/a/link" 'symlink))) + (should (eq 'symlink (plist-get p :class))) + (should (eq 'warning (plist-get p :severity)))) + (should (null (duet--check-symlink "/a/f" 'file)))) + +;;; case-insensitive collisions + +(ert-deftest test-duet-safety-case-collision () + (should (eq 'case-collision + (plist-get (duet--check-case-collision "/b/Foo.txt" '("foo.txt") t) :class))) + ;; case-sensitive filesystem: no collision + (should (null (duet--check-case-collision "/b/Foo.txt" '("foo.txt") nil))) + ;; no name differing only by case + (should (null (duet--check-case-collision "/b/Foo.txt" '("bar.txt") t))) + ;; an exact match is a normal conflict, not a case collision + (should (null (duet--check-case-collision "/b/foo.txt" '("foo.txt") t)))) + +;;; path length and reserved names + +(ert-deftest test-duet-safety-path-length () + (should (eq 'path-too-long (plist-get (duet--check-path-length "/very/long/path" 5) :class))) + (should (null (duet--check-path-length "/short" 255))) + (should (null (duet--check-path-length "/anything" nil)))) + +(ert-deftest test-duet-safety-reserved-name () + (let ((reserved-p (lambda (b) (member (upcase b) '("CON" "NUL"))))) + (should (eq 'reserved-name + (plist-get (duet--check-reserved-name "/b/con" reserved-p) :class))) + (should (null (duet--check-reserved-name "/b/notes.txt" reserved-p))) + (should (null (duet--check-reserved-name "/b/con" nil))))) + +;;; composite + +(ert-deftest test-duet-safety-plan-clean-pair-has-no-problems () + (should (null (duet--plan-safety "/a/f" "/b/f" + (list :file-type (lambda (_) 'file)))))) + +(ert-deftest test-duet-safety-plan-collects-multiple-problems () + "A pair tripping several checks reports each problem." + (let* ((caps (list :file-type (lambda (_) 'fifo) + :max-path-length 3)) + (problems (duet--plan-safety "/a/b" "/a/b" caps)) + (classes (mapcar (lambda (p) (plist-get p :class)) problems))) + (should (memq 'same-file classes)) + (should (memq 'unsupported-special-file classes)) + (should (memq 'path-too-long classes)))) + +;;; safety-composed move planner + +(ert-deftest test-duet-safety-move-skips-unsafe-source () + "A source with a blocking safety error is skipped: no copy, no delete." + (let* ((caps (list :file-type (lambda (_) 'fifo))) + (plan (duet--plan-move-safe '("/a/pipe") "/b" caps))) + (should (= 1 (length plan))) + (should (eq 'skip (plist-get (car plan) :op))) + (should-not (cl-some (lambda (s) (eq 'delete (plist-get s :op))) plan)))) + +(ert-deftest test-duet-safety-move-clean-source-copies-then-gated-delete () + "A safe source gets a copy plus a delete gated on copy success." + (let* ((caps (list :file-type (lambda (_) 'file))) + (plan (duet--plan-move-safe '("/a/f") "/b" caps))) + (should (eq 'copy (plist-get (nth 0 plan) :op))) + (should (eq 'delete (plist-get (nth 1 plan) :op))) + (should (eq 'copy-success (plist-get (nth 1 plan) :gate))))) + +(ert-deftest test-duet-safety-move-never-emits-ungated-delete () + "Across safe and unsafe sources, no delete step lacks the copy-success gate." + (let* ((caps (list :file-type (lambda (p) (if (string-match-p "pipe" p) 'fifo 'file)))) + (plan (duet--plan-move-safe '("/a/f" "/a/pipe" "/a/g") "/b" caps))) + (should-not (cl-some (lambda (s) (and (eq 'delete (plist-get s :op)) + (not (plist-get s :gate)))) + plan)))) + +(provide 'test-duet-safety) +;;; test-duet-safety.el ends here -- cgit v1.2.3