diff options
| -rw-r--r-- | duet.el | 222 | ||||
| -rw-r--r-- | tests/test-duet-transfer.el | 176 |
2 files changed, 398 insertions, 0 deletions
@@ -330,6 +330,228 @@ before DUET will trust it." (list (unless (plist-get (duet-backend-capabilities backend) capability) (format "capability %s is asserted but not declared" capability)))))) +;;; Endpoint matrix and routing + +(defconst duet--ssh-methods '("ssh" "sshx" "scp" "rsync") + "TRAMP methods rsync can transport over directly.") + +(defun duet--local-endpoint-p (ep) + "Return non-nil when classified endpoint EP is local." + (eq (plist-get ep :locality) 'local)) + +(defun duet--remote-endpoint-p (ep) + "Return non-nil when classified endpoint EP is remote." + (eq (plist-get ep :locality) 'remote)) + +(defun duet--ssh-endpoint-p (ep) + "Return non-nil when classified endpoint EP is reachable over ssh." + (and (duet--remote-endpoint-p ep) + (member (plist-get ep :method) duet--ssh-methods))) + +(defun duet--same-remote-host-p (a b) + "Return non-nil when classified endpoints A and B name the same remote host." + (and (duet--remote-endpoint-p a) + (duet--remote-endpoint-p b) + (equal (plist-get a :method) (plist-get b :method)) + (equal (plist-get a :user) (plist-get b :user)) + (equal (plist-get a :host) (plist-get b :host)) + (equal (plist-get a :port) (plist-get b :port)))) + +(defun duet--transfer-route (src dst opts) + "Determine the transfer route between classified SRC and DST given OPTS. + + :local both endpoints local + :local-remote exactly one endpoint remote + :remote-same-host both on the same remote host (ssh in once, copy there) + :remote-direct different remote hosts, direct host-to-host (override only) + :remote-roundtrip different remote hosts, routed through this machine + +Different-host transfers default to the round-trip; direct mode is never +automatic and requires `:direct-remote-to-remote' in OPTS." + (let ((s-local (duet--local-endpoint-p src)) + (d-local (duet--local-endpoint-p dst))) + (cond + ((and s-local d-local) :local) + ((or s-local d-local) :local-remote) + ((duet--same-remote-host-p src dst) :remote-same-host) + ((plist-get opts :direct-remote-to-remote) :remote-direct) + (t :remote-roundtrip)))) + +;;; Built-in backends: rsync (native) and TRAMP (fallback) + +(defun duet--rsync-handles (src dst) + "Score rsync for classified SRC and DST. +rsync handles local and ssh-reachable endpoints. A local pair or a +local/ssh pair scores 10; an ssh-to-ssh pair scores 20 (it needs routing). +Anything not ssh-reachable scores nil so a fallback backend takes it." + (let ((s-ok (or (duet--local-endpoint-p src) (duet--ssh-endpoint-p src))) + (d-ok (or (duet--local-endpoint-p dst) (duet--ssh-endpoint-p dst)))) + (when (and s-ok d-ok) + (if (and (duet--remote-endpoint-p src) (duet--remote-endpoint-p dst)) + 20 + 10)))) + +(defun duet--rsync-endpoint-arg (ep) + "Return the rsync path argument for classified endpoint EP. +A local endpoint uses its localname; a remote one uses rsync's native +\[user@]host:path form (the port travels in the ssh transport flag)." + (if (duet--local-endpoint-p ep) + (plist-get ep :localname) + (concat (when (plist-get ep :user) (concat (plist-get ep :user) "@")) + (plist-get ep :host) ":" (plist-get ep :localname)))) + +(defun duet--rsync-ssh-transport (src dst) + "Return rsync's -e ssh transport flags for SRC/DST, honoring a port." + (let ((port (or (plist-get src :port) (plist-get dst :port)))) + (list "-e" (if port (format "ssh -p %s" port) "ssh")))) + +(defun duet--rsync-command (src dst opts) + "Build an rsync process spec for SRC to DST with OPTS. +OPTS carries :sources (the source paths) and :destination (the destination +directory). Sources and destination become rsync path arguments, and a +remote endpoint adds an ssh transport. File names reach rsync as argv +elements, never interpolated into a shell string." + (let* ((sources (plist-get opts :sources)) + (remote (or (duet--ssh-endpoint-p src) (duet--ssh-endpoint-p dst))) + (src-args (mapcar (lambda (p) + (duet--rsync-endpoint-arg (duet--classify-path p))) + sources))) + (list :argv (append '("rsync" "-a" "--partial" "--info=progress2") + (when remote (duet--rsync-ssh-transport src dst)) + src-args + (list (duet--rsync-endpoint-arg dst))) + :default-directory "/"))) + +(defun duet--tramp-handles (_src _dst) + "Score TRAMP: the universal fallback, costlier than a native transport." + 100) + +(defun duet--tramp-command (_src _dst opts) + "Build the in-process TRAMP transfer spec from OPTS. +TRAMP copies in process rather than spawning a CLI, so there is no argv; the +:tramp marker tells the executor to use the in-process path." + (list :argv nil + :tramp t + :sources (plist-get opts :sources) + :destination (plist-get opts :destination))) + +(defconst duet--rsync-failure-patterns + '((:match "[Pp]ermission denied" :class permission-denied + :cause "The destination rejected the write (permission denied)." + :next-actions (fix-permissions) :safety "Source unchanged.") + (:match "No space left on device" :class destination-full + :cause "The destination filesystem is full." + :next-actions (free-space retry) + :safety "Source unchanged; the destination may hold a partial.") + (:match "\\(protocol version mismatch\\|unexpected tag\\|is your shell clean\\)" + :class rsync-protocol-mismatch + :cause "The remote shell printed text that corrupted rsync's protocol stream." + :next-actions (run-doctor) :safety "Source unchanged.")) + "Known rsync stderr signatures mapped to DUET failure classes.") + +(defun duet--register-builtin-backends () + "Register the stage-1 built-in backends: rsync, with TRAMP as the fallback. +Idempotent: re-registering replaces the prior definitions." + (duet-register-backend + (duet-backend-create + :name 'tramp + :handles #'duet--tramp-handles + :command #'duet--tramp-command + :capabilities '() + :redaction '("\\(://[^:@/]+:\\)[^@]+@") + :cleanup :none)) + (duet-register-backend + (duet-backend-create + :name 'rsync + :handles #'duet--rsync-handles + :command #'duet--rsync-command + :capabilities '(:async t :resume t :progress t) + :redaction :none + :cleanup :verifiable + :normalizer (duet-define-cli-failure-patterns duet--rsync-failure-patterns)))) + +(duet--register-builtin-backends) + +;;; Transfer-spec assembly + +(defun duet--transfer-spec (sources destination-directory &optional opts) + "Build a transfer-spec plist to copy SOURCES into DESTINATION-DIRECTORY. +SOURCES is a list of source paths; the first is representative for backend +selection and routing. Classify both endpoints, select the lowest-cost +backend, determine the route, and delegate argv construction to that +backend's command builder. Return nil when no backend handles the pair." + (let* ((src (duet--classify-path (car sources))) + (dst (duet--classify-path destination-directory)) + (backend (duet--select-backend src dst))) + (when backend + (let* ((bopts (append (list :sources sources + :destination destination-directory) + opts)) + (cmd (funcall (duet-backend-command backend) src dst bopts))) + (list :sources sources + :destination-directory destination-directory + :destination-name (plist-get opts :destination-name) + :backend (duet-backend-name backend) + :route (duet--transfer-route src dst opts) + :argv (plist-get cmd :argv) + :default-directory (plist-get cmd :default-directory) + :process-environment (plist-get cmd :process-environment) + :async (if (plist-member opts :async) (plist-get opts :async) t)))))) + +;;; Conflict and move planning (pure, prompt-free) + +(defun duet--unique-name (dest existing-p) + "Return a free basename near DEST, probing candidates with EXISTING-P. +Append \" (N)\" before the extension, incrementing N until EXISTING-P reports +the candidate path free. Return the basename only." + (let* ((dir (file-name-directory dest)) + (base (file-name-base dest)) + (ext (file-name-extension dest t)) + (n 1) + (candidate (concat dir base " (" (number-to-string n) ")" ext))) + (while (funcall existing-p candidate) + (setq n (1+ n) + candidate (concat dir base " (" (number-to-string n) ")" ext))) + (file-name-nondirectory candidate))) + +(defun duet--conflict-entry (src dst action existing-p) + "Return a conflict-plan entry for SRC/DST resolved with ACTION. +A `rename' action gets a computed free :new-name via EXISTING-P." + (if (eq action 'rename) + (list :source src :dest dst :action 'rename + :new-name (duet--unique-name dst existing-p)) + (list :source src :dest dst :action action))) + +(defun duet--plan-conflicts (items existing-p resolver) + "Return a per-item action plan for ITEMS, prompt-free. +ITEMS is a list of (SOURCE . DEST). EXISTING-P, called on a DEST, reports +whether it already exists. RESOLVER, called on a colliding (SOURCE . DEST), +returns an action (`overwrite', `skip', or `rename') or a cons (ACTION . all) +to apply ACTION to every remaining collision without being called again. +Non-colliding items plan a plain `copy'. Each entry is a plist +\(:source :dest :action [:new-name]); no file is touched." + (let ((sticky nil) (plan nil)) + (dolist (item items (nreverse plan)) + (let ((src (car item)) (dst (cdr item))) + (if (not (funcall existing-p dst)) + (push (list :source src :dest dst :action 'copy) plan) + (let ((action (or sticky (funcall resolver item)))) + (when (and (consp action) (eq (cdr action) 'all)) + (setq sticky (car action) + action (car action))) + (push (duet--conflict-entry src dst action existing-p) plan))))))) + +(defun duet--plan-move (sources) + "Return a move plan for SOURCES, prompt-free. +Each source yields a copy step followed by a delete step gated on that +source's copy success, so a source is never deleted before its copy is +confirmed. Return a flat list of step plists in execution order." + (apply #'append + (mapcar (lambda (s) + (list (list :op 'copy :source s) + (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-transfer.el b/tests/test-duet-transfer.el new file mode 100644 index 0000000..a5d0429 --- /dev/null +++ b/tests/test-duet-transfer.el @@ -0,0 +1,176 @@ +;;; test-duet-transfer.el --- Tests for transfer-spec + planning -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the endpoint matrix (route + backend selection), transfer-spec +;; assembly, and the two pure planners (conflict resolution and move +;; sequencing). Selection tests register the built-in rsync/TRAMP backends +;; into a let-bound registry so they run against a known, isolated set. The +;; planners are pure: existence and conflict-resolution decisions are injected +;; as functions, so no test touches a real file. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +(defmacro test-duet-transfer--with-builtins (&rest body) + "Run BODY with only the built-in backends registered, isolated." + `(let ((duet--backend-registry nil)) + (duet--register-builtin-backends) + ,@body)) + +(defun test-duet-transfer--classify (path) + "Classify PATH; convenience wrapper for route tests." + (duet--classify-path path)) + +;;; Route determination — every matrix cell + +(ert-deftest test-duet-transfer-route-local-to-local () + (should (eq :local + (duet--transfer-route (test-duet-transfer--classify "/tmp/a") + (test-duet-transfer--classify "/tmp/b") + nil)))) + +(ert-deftest test-duet-transfer-route-local-to-remote () + (should (eq :local-remote + (duet--transfer-route (test-duet-transfer--classify "/tmp/a") + (test-duet-transfer--classify "/ssh:host:/b") + nil))) + (should (eq :local-remote + (duet--transfer-route (test-duet-transfer--classify "/ssh:host:/a") + (test-duet-transfer--classify "/tmp/b") + nil)))) + +(ert-deftest test-duet-transfer-route-remote-same-host () + (should (eq :remote-same-host + (duet--transfer-route (test-duet-transfer--classify "/ssh:user@host:/a") + (test-duet-transfer--classify "/ssh:user@host:/b") + nil)))) + +(ert-deftest test-duet-transfer-route-remote-different-host-defaults-roundtrip () + (should (eq :remote-roundtrip + (duet--transfer-route (test-duet-transfer--classify "/ssh:hostA:/a") + (test-duet-transfer--classify "/ssh:hostB:/b") + nil)))) + +(ert-deftest test-duet-transfer-route-remote-different-host-direct-only-on-override () + (should (eq :remote-direct + (duet--transfer-route (test-duet-transfer--classify "/ssh:hostA:/a") + (test-duet-transfer--classify "/ssh:hostB:/b") + '(:direct-remote-to-remote t))))) + +;;; Backend selection — the matrix + +(ert-deftest test-duet-transfer-selects-rsync-for-local-pair () + (test-duet-transfer--with-builtins + (should (eq 'rsync + (duet-backend-name + (duet--select-backend (test-duet-transfer--classify "/tmp/a") + (test-duet-transfer--classify "/tmp/b"))))))) + +(ert-deftest test-duet-transfer-selects-rsync-for-local-ssh-pair () + (test-duet-transfer--with-builtins + (should (eq 'rsync + (duet-backend-name + (duet--select-backend (test-duet-transfer--classify "/tmp/a") + (test-duet-transfer--classify "/ssh:host:/b"))))))) + +(ert-deftest test-duet-transfer-falls-back-to-tramp-for-non-ssh-method () + "An FTP endpoint is not ssh-reachable, so rsync declines and TRAMP wins." + (test-duet-transfer--with-builtins + (should (eq 'tramp + (duet-backend-name + (duet--select-backend (test-duet-transfer--classify "/tmp/a") + (test-duet-transfer--classify "/ftp:host:/b"))))))) + +;;; Transfer-spec assembly + +(ert-deftest test-duet-transfer-spec-local-copy-shape () + "A local copy spec names the rsync backend, the local route, and an argv." + (test-duet-transfer--with-builtins + (let ((spec (duet--transfer-spec '("/tmp/a/file.txt") "/tmp/b" nil))) + (should (eq 'rsync (plist-get spec :backend))) + (should (eq :local (plist-get spec :route))) + (should (equal '("/tmp/a/file.txt") (plist-get spec :sources))) + (should (equal "/tmp/b" (plist-get spec :destination-directory))) + (should (equal "rsync" (car (plist-get spec :argv)))) + (should (member "/tmp/a/file.txt" (plist-get spec :argv))) + (should (eq t (plist-get spec :async)))))) + +(ert-deftest test-duet-transfer-spec-carries-route-for-remote () + (test-duet-transfer--with-builtins + (let ((spec (duet--transfer-spec '("/tmp/a/file.txt") "/ssh:host:/b" nil))) + (should (eq 'rsync (plist-get spec :backend))) + (should (eq :local-remote (plist-get spec :route)))))) + +;;; Conflict planning — pure, prompt-free + +(ert-deftest test-duet-plan-conflicts-no-collisions-all-copy () + "With nothing at the destination, every item plans a plain copy." + (let ((plan (duet--plan-conflicts '(("/a/x" . "/b/x") ("/a/y" . "/b/y")) + (lambda (_d) nil) + (lambda (_i) (error "resolver must not be called"))))) + (should (cl-every (lambda (e) (eq 'copy (plist-get e :action))) plan)))) + +(ert-deftest test-duet-plan-conflicts-resolver-skip-and-overwrite () + "The resolver's action is recorded for each colliding item." + (let ((plan (duet--plan-conflicts '(("/a/x" . "/b/x")) + (lambda (_d) t) + (lambda (_i) 'skip)))) + (should (eq 'skip (plist-get (car plan) :action))))) + +(ert-deftest test-duet-plan-conflicts-rename-computes-free-name () + "A rename action computes a destination name the existence check reports free." + (let* ((taken '("/b/file.txt" "/b/file (1).txt")) + (plan (duet--plan-conflicts '(("/a/file.txt" . "/b/file.txt")) + (lambda (d) (member d taken)) + (lambda (_i) 'rename)))) + (should (eq 'rename (plist-get (car plan) :action))) + (should (equal "file (2).txt" (plist-get (car plan) :new-name))))) + +(ert-deftest test-duet-plan-conflicts-apply-to-all () + "An (action . all) resolution applies to every remaining collision unprompted." + (let ((calls 0)) + (let ((plan (duet--plan-conflicts + '(("/a/x" . "/b/x") ("/a/y" . "/b/y") ("/a/z" . "/b/z")) + (lambda (_d) t) + (lambda (_i) (setq calls (1+ calls)) '(skip . all))))) + (should (= 1 calls)) + (should (cl-every (lambda (e) (eq 'skip (plist-get e :action))) plan))))) + +;;; Move planning — delete only after copy success + +(ert-deftest test-duet-plan-move-pairs-copy-then-gated-delete () + "Each source gets a copy step and a delete step gated on its copy success." + (let ((plan (duet--plan-move '("/a/x" "/a/y")))) + (should (= 4 (length plan))) + (dolist (step plan) + (when (eq 'delete (plist-get step :op)) + (should (eq 'copy-success (plist-get step :gate))))))) + +(ert-deftest test-duet-plan-move-no-ungated-delete () + "No delete step is ever emitted without the copy-success gate." + (let ((plan (duet--plan-move '("/a/x" "/a/y" "/a/z")))) + (should-not (cl-some (lambda (s) (and (eq 'delete (plist-get s :op)) + (not (plist-get s :gate)))) + plan)))) + +(provide 'test-duet-transfer) +;;; test-duet-transfer.el ends here |