diff options
| -rw-r--r-- | duet.el | 561 | ||||
| -rw-r--r-- | tests/test-duet-pane.el | 6 | ||||
| -rw-r--r-- | tests/test-duet-transfer-exec.el | 510 | ||||
| -rw-r--r-- | tests/test-integration-duet-transfer.el | 168 |
4 files changed, 1224 insertions, 21 deletions
@@ -35,6 +35,7 @@ (require 'tramp) (require 'cl-lib) +(require 'dired) (defgroup duet nil "Dual-pane file commander over dirvish/dired." @@ -495,6 +496,7 @@ Idempotent: re-registering replaces the prior definitions." :command #'duet--rsync-command :capabilities '(:async t :resume t :progress t) :redaction :none + :temp-pattern "\\`\\..*\\.[A-Za-z0-9]\\{6\\}\\'" :cleanup :verifiable :normalizer (duet-define-cli-failure-patterns duet--rsync-failure-patterns)))) @@ -751,25 +753,8 @@ nil means the current directory when `duet' is invoked." (interactive) (user-error "DUET: edit is not implemented yet")) -(defun duet-copy () - "Copy the marked files to the other pane. Arrives with transfer execution." - (interactive) - (user-error "DUET: copy is not implemented yet")) - -(defun duet-move () - "Move the marked files to the other pane. Arrives with transfer execution." - (interactive) - (user-error "DUET: move is not implemented yet")) - -(defun duet-mkdir () - "Make a directory in the active pane. Arrives with transfer execution." - (interactive) - (user-error "DUET: mkdir is not implemented yet")) - -(defun duet-delete () - "Delete the marked files (to trash). Arrives with transfer execution." - (interactive) - (user-error "DUET: delete is not implemented yet")) +;; duet-copy, duet-move, duet-mkdir, and duet-delete are defined with the +;; transfer execution engine below, since they drive it. (defun duet-quit () "Close the DUET commander, restoring the window layout from before launch." @@ -856,5 +841,543 @@ right. Each pane is a dired buffer with `duet-mode' enabled. `duet-quit' (with-selected-window (split-window-right) (duet--open-pane right-dir)))) +;;; Transfer execution engine, serial queue, and log + +;; A transfer is built from a transfer-spec, enqueued, and run as an async +;; subprocess. The queue runs `duet-max-concurrent-transfers' at a time; the +;; rest wait. The process filter is the hot path, so it only counts and bounds +;; output and schedules a coalesced log render — it never refreshes panes or +;; draws directly. Pane refresh happens once per batch, after the sentinel. +;; The state machine: queued -> running (-> stalled <-> running) -> done | +;; failed | cleanup-unverified, with cancelling as the transient kill state. + +(defcustom duet-max-concurrent-transfers 1 + "Maximum number of transfers DUET runs at once. +Transfers submitted past this limit wait in the queue until a slot frees. The +default of 1 keeps disk and network contention predictable; raise it when +independent transfers target unrelated devices." + :type 'integer + :group 'duet) + +(defcustom duet-transfer-stderr-limit 65536 + "Trailing bytes of a transfer's output DUET retains for failure evidence. +A long transfer's progress output is bounded to this many trailing bytes so it +cannot grow memory without limit; the total byte count is tracked separately." + :type 'integer + :group 'duet) + +(defcustom duet-log-render-interval 0.2 + "Seconds DUET coalesces transfer output before redrawing the log. +Output arrives in many small chunks; rendering is deferred to one timer per +interval so a high-volume transfer never drives the display from its filter." + :type 'number + :group 'duet) + +(defcustom duet-transfer-stall-timeout 60 + "Seconds without output after which a running transfer is flagged stalled. +Flagging is advisory: the transfer keeps running and clears the flag on its +next chunk of output. nil disables stall detection." + :type '(choice (const :tag "Disabled" nil) integer) + :group 'duet) + +(cl-defstruct (duet-transfer (:constructor duet-transfer-create) (:copier nil)) + "One transfer's identity, live process, and terminal result. + +Slots: + + id stable monotonic identifier + spec the originating transfer-spec plist + backend backend name (symbol) + route the endpoint route (e.g. `:local') + status queued/running/stalled/cancelling/done/failed/ + cleanup-unverified + process the live process object, or nil + exit integer exit status, or nil + signal terminating signal number, or nil + failure normalized failure plist, or nil on success + stderr bounded trailing output retained as evidence + stderr-bytes total output byte count seen + output-count number of output chunks received + move-p non-nil when this transfer is the copy half of a move + destination-directory directory the transfer writes into + source-directories parent directories of the sources, for refresh + cleanup-verified non-nil when no stray temp files remain after a stop + stall-timer the per-transfer stall timer, or nil" + id spec backend route status process + exit signal failure + (stderr "") (stderr-bytes 0) (output-count 0) + move-p destination-directory source-directories + cleanup-verified stall-timer) + +(defconst duet--active-statuses '(running stalled cancelling) + "Statuses at which a transfer still occupies a concurrency slot.") + +(defconst duet--terminal-statuses '(done failed cleanup-unverified) + "Statuses at which a transfer is finished and off the queue.") + +(defvar duet--transfer-id-counter 0 + "Monotonic source of stable transfer ids.") + +(defvar duet--transfers nil + "All transfers created this session, most recent first.") + +(defvar duet--transfer-queue nil + "Non-terminal transfers, in submission order.") + +(defun duet--next-transfer-id () + "Return the next stable transfer id." + (cl-incf duet--transfer-id-counter)) + +(defun duet--source-directories (sources) + "Return the unique, normalized parent directories of SOURCES." + (delete-dups + (mapcar (lambda (s) + (file-name-as-directory + (expand-file-name (or (file-name-directory s) ".")))) + sources))) + +(defun duet--make-transfer (spec &optional move-p) + "Create a queued `duet-transfer' from transfer-spec SPEC. +Non-nil MOVE-P marks the transfer as the copy half of a move." + (duet-transfer-create + :id (duet--next-transfer-id) + :spec spec + :backend (plist-get spec :backend) + :route (plist-get spec :route) + :status 'queued + :move-p move-p + :destination-directory (plist-get spec :destination-directory) + :source-directories (duet--source-directories (plist-get spec :sources)))) + +;;; Queue and concurrency + +(defun duet--running-transfers () + "Return the queued transfers that currently occupy a concurrency slot." + (cl-remove-if-not + (lambda (tr) (memq (duet-transfer-status tr) duet--active-statuses)) + duet--transfer-queue)) + +(defun duet--enqueue-transfer (tr) + "Record TR in the history and append it to the run queue. Return TR." + (push tr duet--transfers) + (setq duet--transfer-queue (append duet--transfer-queue (list tr))) + tr) + +(defun duet--pump-queue () + "Start queued transfers until the concurrency limit is reached." + (let ((next nil)) + (while (and (< (length (duet--running-transfers)) + duet-max-concurrent-transfers) + (setq next (cl-find 'queued duet--transfer-queue + :key #'duet-transfer-status))) + (duet--start-transfer next)))) + +(defun duet--run-transfer (spec &optional move-p) + "Enqueue transfer-SPEC, pump the queue, and return the `duet-transfer'. +SPEC must carry a runnable :argv. An in-process (:tramp) or both-remote +\(:exec-mode) spec is not executed in this phase and signals a `user-error'; +those routes land with Phase 6. MOVE-P marks the transfer as a move so its +sources are deleted once the copy succeeds." + (unless (and (consp (plist-get spec :argv)) + (cl-every #'stringp (plist-get spec :argv))) + (user-error "DUET: this transfer route is not executable yet (no local argv)")) + (let ((tr (duet--make-transfer spec move-p))) + (duet--enqueue-transfer tr) + (duet--pump-queue) + tr)) + +;;; Launch and the process boundary + +(defvar duet--transfer-launcher #'duet--launch-process + "Function called with a `duet-transfer' to spawn its process and return it. +The process-boundary tests stub this so no real subprocess runs.") + +(defun duet--launch-process (tr) + "Spawn TR's backend process with a bounded filter and a sentinel." + (let* ((spec (duet-transfer-spec tr)) + (default-directory (or (plist-get spec :default-directory) "/")) + (proc (make-process + :name (format "duet-transfer-%d" (duet-transfer-id tr)) + :command (plist-get spec :argv) + :connection-type 'pipe + :noquery t + :filter (lambda (_p chunk) (duet--transfer-filter tr chunk)) + :sentinel (lambda (p _e) (duet--transfer-sentinel tr p))))) + (setf (duet-transfer-process tr) proc) + proc)) + +(defun duet--start-transfer (tr) + "Move TR to `running' and launch it; a launch error fails it cleanly." + (setf (duet-transfer-status tr) 'running) + (condition-case err + (progn (funcall duet--transfer-launcher tr) + (duet--arm-stall-timer tr)) + (error + (duet--transfer-handle-result + tr (list :launch-error (error-message-string err)))))) + +;;; Bounded output filter and stall flagging + +(defun duet--transfer-accumulate-stderr (tr chunk) + "Append CHUNK to TR's retained output, bounded to `duet-transfer-stderr-limit'." + (let* ((combined (concat (duet-transfer-stderr tr) chunk)) + (limit duet-transfer-stderr-limit) + (kept (if (> (length combined) limit) + (substring combined (- (length combined) limit)) + combined))) + (setf (duet-transfer-stderr tr) kept + (duet-transfer-stderr-bytes tr) + (+ (duet-transfer-stderr-bytes tr) (length chunk))))) + +(defun duet--transfer-filter (tr chunk) + "Record output CHUNK for TR: count it, bound it, recover, redraw. +Runs from the process filter, so it does no pane refresh and no direct +rendering — it only schedules a coalesced log render." + (cl-incf (duet-transfer-output-count tr)) + (duet--transfer-accumulate-stderr tr chunk) + (when (eq (duet-transfer-status tr) 'stalled) + (setf (duet-transfer-status tr) 'running)) + (duet--rearm-stall-timer tr) + (duet--schedule-log-render)) + +(defun duet--arm-stall-timer (tr) + "Arm TR's stall timer when stall detection is enabled." + (when duet-transfer-stall-timeout + (setf (duet-transfer-stall-timer tr) + (run-with-timer duet-transfer-stall-timeout nil + #'duet--mark-stalled tr)))) + +(defun duet--cancel-stall-timer (tr) + "Cancel and clear TR's stall timer." + (when (timerp (duet-transfer-stall-timer tr)) + (cancel-timer (duet-transfer-stall-timer tr))) + (setf (duet-transfer-stall-timer tr) nil)) + +(defun duet--rearm-stall-timer (tr) + "Reset TR's stall timer after fresh output." + (duet--cancel-stall-timer tr) + (duet--arm-stall-timer tr)) + +(defun duet--mark-stalled (tr) + "Flag a still-running TR as stalled after a silent stretch." + (when (eq (duet-transfer-status tr) 'running) + (setf (duet-transfer-status tr) 'stalled) + (duet--schedule-log-render))) + +;;; Throttled log render + +(defvar duet--log-render-timer nil + "Pending coalesced log-render timer, or nil.") + +(defconst duet--transfer-log-buffer "*DUET Transfers*" + "Name of the buffer holding the transfer log.") + +(defun duet--schedule-log-render () + "Schedule a single coalesced redraw of the transfer log." + (unless duet--log-render-timer + (setq duet--log-render-timer + (run-with-timer duet-log-render-interval nil + #'duet--render-transfer-log)))) + +(defun duet--render-transfer-log () + "Clear the pending render timer and draw the transfer log once." + (when (timerp duet--log-render-timer) + (cancel-timer duet--log-render-timer)) + (setq duet--log-render-timer nil) + (duet--draw-transfer-log)) + +(defun duet--draw-transfer-log () + "Write every transfer's log record into the transfer-log buffer." + (with-current-buffer (get-buffer-create duet--transfer-log-buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (dolist (tr (reverse duet--transfers)) + (insert (duet--format-log-line (duet--transfer-log-record tr)) "\n"))))) + +(defun duet--format-log-line (record) + "Format one transfer-log RECORD as a single display line." + (format "[%s] #%d %s %s %s" + (plist-get record :status) + (plist-get record :id) + (plist-get record :backend) + (or (plist-get record :route) "") + (plist-get record :argv))) + +;;; Log-record schema + +(defun duet--redact-argv (tr) + "Return TR's argv as a single string with the backend's secrets redacted." + (let* ((argv (plist-get (duet-transfer-spec tr) :argv)) + (joined (mapconcat #'identity argv " ")) + (backend (duet-backend-by-name (duet-transfer-backend tr))) + (patterns (and backend (duet-backend-redaction backend)))) + (duet--redact joined patterns))) + +(defun duet--transfer-log-record (tr) + "Return TR's log record: a plist of its id, route, redacted argv, and result." + (list :id (duet-transfer-id tr) + :backend (duet-transfer-backend tr) + :route (duet-transfer-route tr) + :argv (duet--redact-argv tr) + :exit (duet-transfer-exit tr) + :signal (duet-transfer-signal tr) + :class (plist-get (duet-transfer-failure tr) :class) + :evidence (plist-get (duet-transfer-failure tr) :evidence) + :status (duet-transfer-status tr))) + +;;; Stray temp-file detection (cleanup verification) + +(defvar duet--temp-file-lister #'duet--list-stray-temp-files + "Function called with a `duet-transfer' returning stray temp-file paths. +The cancellation/cleanup tests inject a stub.") + +(defun duet--list-stray-temp-files (tr) + "Return TR backend's leftover temp files in the destination directory." + (let* ((backend (duet-backend-by-name (duet-transfer-backend tr))) + (pattern (and backend (duet-backend-temp-pattern backend))) + (dir (duet-transfer-destination-directory tr))) + (when (and pattern dir (file-directory-p dir)) + (directory-files dir t pattern t)))) + +;;; Sentinel and terminal-result handling + +(defun duet--process-result (proc) + "Return a result plist for finished process PROC: (:signal N) or (:exit N)." + (let ((status (process-status proc)) + (code (process-exit-status proc))) + (if (eq status 'signal) (list :signal code) (list :exit code)))) + +(defun duet--transfer-sentinel (tr proc) + "Resolve TR's result when its process PROC has exited or been signalled." + (when (memq (process-status proc) '(exit signal)) + (duet--transfer-handle-result tr (duet--process-result proc)))) + +(defun duet--result-failure-context (tr result) + "Return a failure context plist for RESULT, or nil for a clean exit. +TR supplies the retained output as evidence." + (cond + ((plist-get result :launch-error) + (list :launch-error (plist-get result :launch-error))) + ((plist-get result :signal) + (list :signal (plist-get result :signal) :stderr (duet-transfer-stderr tr))) + ((and (integerp (plist-get result :exit)) (zerop (plist-get result :exit))) + nil) + (t (list :exit (plist-get result :exit) :stderr (duet-transfer-stderr tr))))) + +(defun duet--transfer-handle-result (tr result) + "Resolve TR's terminal state from process RESULT and advance the queue." + (duet--cancel-stall-timer tr) + (setf (duet-transfer-exit tr) (plist-get result :exit) + (duet-transfer-signal tr) (plist-get result :signal)) + (let ((context (duet--result-failure-context tr result))) + (if (null context) + (duet--finish-transfer tr 'done) + (let ((backend (duet-backend-by-name (duet-transfer-backend tr)))) + (setf (duet-transfer-failure tr) + (and backend (duet--normalize-failure backend context))) + (duet--finish-transfer tr 'failed))))) + +(defun duet--needs-cleanup-check-p (tr proposed) + "Return non-nil when TR's non-success stop (PROPOSED) needs a temp-file check." + (and (not (eq proposed 'done)) + (let ((b (duet-backend-by-name (duet-transfer-backend tr)))) + (and b + (eq (duet-backend-cleanup b) :verifiable) + (duet-backend-temp-pattern b))))) + +(defun duet--resolve-terminal-status (tr proposed) + "Return TR's terminal status, refining a stopped transfer that left temps. +A success keeps PROPOSED; a non-success with stray temp files becomes +`cleanup-unverified'. Records `cleanup-verified' either way." + (if (not (duet--needs-cleanup-check-p tr proposed)) + (progn (setf (duet-transfer-cleanup-verified tr) t) proposed) + (let ((strays (funcall duet--temp-file-lister tr))) + (setf (duet-transfer-cleanup-verified tr) (null strays)) + (if strays 'cleanup-unverified proposed)))) + +(defun duet--finish-transfer (tr proposed) + "Commit TR to its terminal status, finalize a move, refresh, and pump. +PROPOSED is `done' or `failed'; cleanup verification can refine it." + (let ((status (duet--resolve-terminal-status tr proposed))) + (setf (duet-transfer-status tr) status) + (setq duet--transfer-queue (delq tr duet--transfer-queue)) + (when (eq status 'done) + (when (duet-transfer-move-p tr) (duet--finalize-move tr)) + (duet--schedule-completion-refresh tr)) + (duet--schedule-log-render) + (duet--pump-queue) + status)) + +;;; Move finalization (delete sources only after the copy succeeds) + +(defun duet--delete-source (path) + "Delete PATH (file or directory) outright; missing is a no-op." + (cond ((not (file-exists-p path)) nil) + ((file-directory-p path) (delete-directory path t)) + (t (delete-file path)))) + +(defun duet--finalize-move (tr) + "Delete TR's sources now that its copy has succeeded (success is the gate)." + (dolist (s (plist-get (duet-transfer-spec tr) :sources)) + (duet--delete-source s))) + +;;; Coalesced pane refresh + +(defvar duet--refresh-pending nil + "Set of directories awaiting a coalesced refresh.") + +(defvar duet--refresh-timer nil + "Pending coalesced pane-refresh timer, or nil.") + +(defun duet--schedule-pane-refresh (dir) + "Queue DIR for a single coalesced pane refresh." + (cl-pushnew (file-name-as-directory (expand-file-name dir)) + duet--refresh-pending :test #'equal) + (unless duet--refresh-timer + (setq duet--refresh-timer + (run-with-timer 0 nil #'duet--do-pane-refresh)))) + +(defun duet--do-pane-refresh () + "Refresh every pending directory exactly once, then clear the set." + (when (timerp duet--refresh-timer) (cancel-timer duet--refresh-timer)) + (setq duet--refresh-timer nil) + (let ((dirs duet--refresh-pending)) + (setq duet--refresh-pending nil) + (dolist (d dirs) (duet--refresh-dir d)))) + +(defun duet--refresh-dir (dir) + "Revert any Dired buffer visiting DIR." + (dolist (buf (dired-buffers-for-dir (expand-file-name dir))) + (with-current-buffer buf (revert-buffer nil t)))) + +(defun duet--schedule-completion-refresh (tr) + "Schedule a refresh of TR's destination, and its sources after a move." + (when (duet-transfer-destination-directory tr) + (duet--schedule-pane-refresh (duet-transfer-destination-directory tr))) + (when (duet-transfer-move-p tr) + (dolist (d (duet-transfer-source-directories tr)) + (duet--schedule-pane-refresh d)))) + +;;; Cancellation + +(defun duet--kill-process (tr) + "Interrupt then delete TR's process if it is live." + (let ((proc (duet-transfer-process tr))) + (when (process-live-p proc) + (interrupt-process proc) + (delete-process proc)))) + +(defun duet--cancel-transfer (tr) + "Request cancellation of non-terminal TR. +Move it to `cancelling' and kill its process; the sentinel then records +whether the backend's temp cleanup could be verified." + (unless (memq (duet-transfer-status tr) duet--terminal-statuses) + (setf (duet-transfer-status tr) 'cancelling) + (duet--cancel-stall-timer tr) + (duet--kill-process tr))) + +(defun duet-cancel-transfer () + "Cancel the most recent transfer that has not yet finished." + (interactive) + (let ((tr (cl-find-if + (lambda (x) (not (memq (duet-transfer-status x) duet--terminal-statuses))) + duet--transfers))) + (unless tr (user-error "DUET: no active transfer to cancel")) + (duet--cancel-transfer tr) + (message "DUET: cancelling transfer #%d" (duet-transfer-id tr)))) + +;;; Failure explanation + +(defun duet--safety-text (safety) + "Render a failure SAFETY value (string or symbol) as user-facing text." + (cond ((stringp safety) safety) + ((eq safety :generic) "Outcome unverified; inspect the destination.") + (t "Unknown."))) + +(defun duet--format-failure-explanation (tr) + "Return a human-readable explanation of TR's outcome. +For a failure it states the class, cause, safety, evidence, and next actions; +for a success it says so." + (let ((f (duet-transfer-failure tr))) + (if (null f) + (format "Transfer #%d completed successfully." (duet-transfer-id tr)) + (mapconcat + #'identity + (list (format "Transfer #%d failed: %s" (duet-transfer-id tr) + (plist-get f :class)) + (format "Cause: %s" (plist-get f :cause)) + (format "Safety: %s" (duet--safety-text (plist-get f :safety))) + (format "Evidence: %s" + (if (plist-get f :evidence) + (mapconcat #'identity (plist-get f :evidence) " | ") + "(none)")) + (format "Next: %s" + (mapconcat #'symbol-name (plist-get f :next-actions) ", "))) + "\n")))) + +(defun duet-explain-transfer-failure () + "Show the failure explanation for the most recent transfer in a buffer." + (interactive) + (let ((tr (car duet--transfers))) + (unless tr (user-error "DUET: no transfers to explain")) + (with-current-buffer (get-buffer-create "*DUET Transfer Failure*") + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (duet--format-failure-explanation tr))) + (display-buffer (current-buffer))))) + +;;; Pane actions wired to the engine + +(defun duet--submit-transfer (sources destination-directory move-p) + "Build and run a transfer of SOURCES into DESTINATION-DIRECTORY. +MOVE-P marks a move. Draw the log and return the `duet-transfer'. Signal a +`user-error' when nothing is selected or no backend handles the pair." + (unless sources (user-error "DUET: no files selected")) + (let ((spec (duet--transfer-spec sources destination-directory))) + (unless spec (user-error "DUET: no backend handles this transfer")) + (prog1 (duet--run-transfer spec move-p) + (duet--draw-transfer-log)))) + +(defun duet--start-pane-transfer (move-p) + "Transfer the selected files in the active pane to the other pane. +MOVE-P marks a move. Show the transfer log afterward." + (let ((tr (duet--submit-transfer (dired-get-marked-files) + (duet--pane-directory (duet--other-pane)) + move-p))) + (display-buffer duet--transfer-log-buffer) + tr)) + +(defun duet-copy () + "Copy the marked files in the active pane to the other pane." + (interactive) + (duet--start-pane-transfer nil)) + +(defun duet-move () + "Move the marked files in the active pane to the other pane." + (interactive) + (duet--start-pane-transfer t)) + +(defun duet-mkdir (name) + "Create directory NAME in the active pane, then refresh it." + (interactive "sNew directory name: ") + (let ((dir (expand-file-name name default-directory))) + (make-directory dir t) + (duet--schedule-pane-refresh default-directory) + (message "DUET: created %s" dir))) + +(defun duet-delete () + "Delete the marked files in the active pane to trash, then refresh." + (interactive) + (let ((files (dired-get-marked-files)) + (delete-by-moving-to-trash t)) + (unless files (user-error "DUET: no files selected")) + (when (yes-or-no-p (format "Delete %d item(s) to trash? " (length files))) + (dolist (f files) + (if (file-directory-p f) + (delete-directory f t t) + (delete-file f t))) + (duet--schedule-pane-refresh default-directory) + (message "DUET: deleted %d item(s)" (length files))))) + (provide 'duet) ;;; duet.el ends here diff --git a/tests/test-duet-pane.el b/tests/test-duet-pane.el index df9866b..433035c 100644 --- a/tests/test-duet-pane.el +++ b/tests/test-duet-pane.el @@ -82,8 +82,10 @@ ;;; Not-yet-implemented action commands (ert-deftest test-duet-pane-unimplemented-actions-error () - "The transfer/file actions announce themselves until their phase lands." - (dolist (cmd '(duet-view duet-edit duet-copy duet-move duet-mkdir duet-delete)) + "The viewer actions announce themselves until the viewer phase lands. +The transfer actions (copy/move/mkdir/delete) are wired to the engine and are +covered in test-duet-transfer-exec.el." + (dolist (cmd '(duet-view duet-edit)) (should-error (funcall cmd) :type 'user-error))) ;;; Launch, quit, and two-window resolution against a real frame diff --git a/tests/test-duet-transfer-exec.el b/tests/test-duet-transfer-exec.el new file mode 100644 index 0000000..f93a4fa --- /dev/null +++ b/tests/test-duet-transfer-exec.el @@ -0,0 +1,510 @@ +;;; test-duet-transfer-exec.el --- Tests for the transfer execution engine -*- 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: + +;; Process-boundary tests for the Phase 5 transfer engine: the serial queue +;; and its concurrency limit, the bounded output filter, throttled log +;; rendering, terminal-result classification, coalesced pane refresh, +;; cancellation with cleanup verification, the failure explainer, and the +;; log-record schema. The process boundary is stubbed (a no-op launcher and +;; injected result plists), so no real subprocess runs here; real-rsync +;; coverage lives in test-integration-duet-transfer.el. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;; A clean engine per test: fresh counters, empty queue/history, no live +;; timers, stall detection off (mark-stalled is exercised directly), a no-op +;; launcher so `duet--start-transfer' spawns nothing. Real render/refresh +;; timers created during a test are cancelled on exit so they never fire into +;; the next one. +(defmacro duet-test--with-clean-engine (&rest body) + (declare (indent 0)) + `(let ((duet--transfer-id-counter 0) + (duet--transfers nil) + (duet--transfer-queue nil) + (duet--log-render-timer nil) + (duet--refresh-pending nil) + (duet--refresh-timer nil) + (duet-transfer-stall-timeout nil) + (duet-max-concurrent-transfers 1) + (duet--transfer-launcher (lambda (_tr) nil))) + (unwind-protect (progn ,@body) + (when (timerp duet--log-render-timer) (cancel-timer duet--log-render-timer)) + (when (timerp duet--refresh-timer) (cancel-timer duet--refresh-timer))))) + +(defun duet-test--argv-spec (&rest overrides) + "A minimal runnable local rsync transfer-spec, with plist OVERRIDES applied." + (append overrides + (list :backend 'rsync :route :local + :sources '("/src/a.txt") + :destination-directory "/dst" + :argv '("rsync" "-a" "/src/a.txt" "/dst")))) + +;;; Transfer records and ids + +(ert-deftest test-duet-exec-make-transfer-assigns-monotonic-id () + (duet-test--with-clean-engine + (let ((a (duet--make-transfer (duet-test--argv-spec))) + (b (duet--make-transfer (duet-test--argv-spec)))) + (should (= 1 (duet-transfer-id a))) + (should (= 2 (duet-transfer-id b))) + (should (eq 'queued (duet-transfer-status a))) + (should (eq 'rsync (duet-transfer-backend a))) + (should (eq :local (duet-transfer-route a))) + (should (equal '("/src/") (duet-transfer-source-directories a)))))) + +;;; Queue + concurrency limit + +(ert-deftest test-duet-exec-queue-runs-one-at-a-time () + (duet-test--with-clean-engine + (let* ((duet-max-concurrent-transfers 1) + (a (duet--run-transfer (duet-test--argv-spec))) + (b (duet--run-transfer (duet-test--argv-spec)))) + (should (eq 'running (duet-transfer-status a))) + (should (eq 'queued (duet-transfer-status b))) + (duet--transfer-handle-result a '(:exit 0)) + (should (eq 'done (duet-transfer-status a))) + (should (eq 'running (duet-transfer-status b))) + (should (not (memq a duet--transfer-queue))) + (should (memq a duet--transfers))))) + +(ert-deftest test-duet-exec-queue-honors-max-concurrent () + (duet-test--with-clean-engine + (let ((duet-max-concurrent-transfers 2)) + (let ((a (duet--run-transfer (duet-test--argv-spec))) + (b (duet--run-transfer (duet-test--argv-spec))) + (c (duet--run-transfer (duet-test--argv-spec)))) + (should (eq 'running (duet-transfer-status a))) + (should (eq 'running (duet-transfer-status b))) + (should (eq 'queued (duet-transfer-status c))))))) + +(ert-deftest test-duet-exec-run-transfer-refuses-deferred-specs () + (duet-test--with-clean-engine + (should-error + (duet--run-transfer '(:backend tramp :route :local-remote :tramp t + :destination-directory "/dst")) + :type 'user-error) + (should-error + (duet--run-transfer '(:backend rsync :route :remote-roundtrip + :exec-mode rsync-remote-to-remote + :destination-directory "/dst")) + :type 'user-error))) + +;;; Bounded output filter + +(ert-deftest test-duet-exec-filter-bounds-retained-output () + (duet-test--with-clean-engine + (let ((duet-transfer-stderr-limit 10) + (tr (duet--make-transfer (duet-test--argv-spec)))) + (duet--transfer-filter tr "abcdefgh") + (duet--transfer-filter tr "ijklmnop") + (should (= 10 (length (duet-transfer-stderr tr)))) + (should (string= "ghijklmnop" (duet-transfer-stderr tr))) + (should (= 2 (duet-transfer-output-count tr))) + (should (= 16 (duet-transfer-stderr-bytes tr)))))) + +;;; Throttled log render + +(ert-deftest test-duet-exec-render-throttled-to-one-timer () + (duet-test--with-clean-engine + (let ((timer-calls 0)) + (cl-letf (((symbol-function 'run-with-timer) + (lambda (&rest _) (cl-incf timer-calls) 'fake-timer))) + (let ((tr (duet--make-transfer (duet-test--argv-spec)))) + (duet--transfer-filter tr "x") + (duet--transfer-filter tr "y") + (duet--transfer-filter tr "z") + (should (= 1 timer-calls)) + (should (eq 'fake-timer duet--log-render-timer))))))) + +(ert-deftest test-duet-exec-render-rearms-after-flush () + (duet-test--with-clean-engine + (let ((timer-calls 0)) + (cl-letf (((symbol-function 'run-with-timer) + (lambda (&rest _) (cl-incf timer-calls) 'fake-timer))) + (duet--schedule-log-render) + (should (= 1 timer-calls)) + (duet--render-transfer-log) + (should (null duet--log-render-timer)) + (duet--schedule-log-render) + (should (= 2 timer-calls)))))) + +;;; Stall flagging + +(ert-deftest test-duet-exec-stall-marks-and-recovers () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (should (eq 'running (duet-transfer-status tr))) + (duet--mark-stalled tr) + (should (eq 'stalled (duet-transfer-status tr))) + ;; a stalled transfer still occupies a slot + (should (memq tr (duet--running-transfers))) + (duet--transfer-filter tr "more output") + (should (eq 'running (duet-transfer-status tr)))))) + +(ert-deftest test-duet-exec-mark-stalled-only-when-running () + (duet-test--with-clean-engine + (let ((tr (duet--make-transfer (duet-test--argv-spec)))) + (setf (duet-transfer-status tr) 'done) + (duet--mark-stalled tr) + (should (eq 'done (duet-transfer-status tr)))))) + +;;; Terminal-result classification + +(ert-deftest test-duet-exec-handle-result-success () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:exit 0)) + (should (eq 'done (duet-transfer-status tr))) + (should (null (duet-transfer-failure tr))) + (should (= 0 (duet-transfer-exit tr))) + (should (duet-transfer-cleanup-verified tr))))) + +(ert-deftest test-duet-exec-handle-result-nonzero-exit-normalizes () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (setf (duet-transfer-stderr tr) "rsync: mkstemp failed: Permission denied (13)") + (duet--transfer-handle-result tr '(:exit 23)) + (should (eq 'failed (duet-transfer-status tr))) + (should (eq 'permission-denied (plist-get (duet-transfer-failure tr) :class))) + (should (= 23 (duet-transfer-exit tr)))))) + +(ert-deftest test-duet-exec-handle-result-signal-fails () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:signal 15)) + (should (eq 'failed (duet-transfer-status tr))) + (should (eq 'cancelled (plist-get (duet-transfer-failure tr) :class))) + (should (= 15 (duet-transfer-signal tr)))))) + +(ert-deftest test-duet-exec-handle-result-launch-error-fails () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:launch-error "No such file or directory")) + (should (eq 'failed (duet-transfer-status tr))) + (should (eq 'launch-failure (plist-get (duet-transfer-failure tr) :class)))))) + +(ert-deftest test-duet-exec-start-transfer-launch-error-is-caught () + (duet-test--with-clean-engine + (let ((duet--transfer-launcher + (lambda (_tr) (error "boom: cannot spawn")))) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (should (eq 'failed (duet-transfer-status tr))) + (should (eq 'launch-failure (plist-get (duet-transfer-failure tr) :class))))))) + +;;; Coalesced pane refresh + +(ert-deftest test-duet-exec-refresh-coalesced-to-one-timer () + (duet-test--with-clean-engine + (let ((timer-calls 0)) + (cl-letf (((symbol-function 'run-with-timer) + (lambda (&rest _) (cl-incf timer-calls) 'fake-timer))) + (duet--schedule-pane-refresh "/a") + (duet--schedule-pane-refresh "/a") + (duet--schedule-pane-refresh "/b") + (should (= 1 timer-calls)) + (should (= 2 (length duet--refresh-pending))) + (should (member "/a/" duet--refresh-pending)) + (should (member "/b/" duet--refresh-pending)))))) + +(ert-deftest test-duet-exec-success-schedules-dest-refresh () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) 'fake-timer))) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:exit 0)) + (should (member "/dst/" duet--refresh-pending)))))) + +(ert-deftest test-duet-exec-move-success-schedules-source-and-dest () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) 'fake-timer))) + (let ((tr (duet--run-transfer + (duet-test--argv-spec :sources '("/src/a.txt")) + t))) + (duet--transfer-handle-result tr '(:exit 0)) + (should (member "/dst/" duet--refresh-pending)) + (should (member "/src/" duet--refresh-pending)))))) + +;;; Cancellation + cleanup verification + +(ert-deftest test-duet-exec-cancel-transitions-to-cancelling () + (duet-test--with-clean-engine + (let ((killed nil)) + (cl-letf (((symbol-function 'duet--kill-process) + (lambda (_tr) (setq killed t)))) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--cancel-transfer tr) + (should (eq 'cancelling (duet-transfer-status tr))) + (should killed)))))) + +(ert-deftest test-duet-exec-cancel-clean-temp-finishes-failed () + (duet-test--with-clean-engine + (let ((duet--temp-file-lister (lambda (_tr) nil))) + (cl-letf (((symbol-function 'duet--kill-process) #'ignore)) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--cancel-transfer tr) + (duet--transfer-handle-result tr '(:signal 15)) + (should (eq 'failed (duet-transfer-status tr))) + (should (duet-transfer-cleanup-verified tr))))))) + +(ert-deftest test-duet-exec-cancel-stray-temp-flags-cleanup-unverified () + (duet-test--with-clean-engine + (let ((duet--temp-file-lister (lambda (_tr) '("/dst/.a.txt.AbCdEf")))) + (cl-letf (((symbol-function 'duet--kill-process) #'ignore)) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--cancel-transfer tr) + (duet--transfer-handle-result tr '(:signal 15)) + (should (eq 'cleanup-unverified (duet-transfer-status tr))) + (should-not (duet-transfer-cleanup-verified tr))))))) + +(ert-deftest test-duet-exec-cancel-terminal-transfer-is-noop () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:exit 0)) + (duet--cancel-transfer tr) + (should (eq 'done (duet-transfer-status tr)))))) + +;;; Failure explanation + +(ert-deftest test-duet-exec-format-failure-explanation () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (setf (duet-transfer-stderr tr) "rsync: Permission denied (13)") + (duet--transfer-handle-result tr '(:exit 23)) + (let ((s (duet--format-failure-explanation tr))) + (should (string-match-p "permission denied" s)) + (should (string-match-p "fix-permissions" s)) + (should (string-match-p "Source unchanged" s)))))) + +(ert-deftest test-duet-exec-format-explanation-success () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:exit 0)) + (should (string-match-p "completed successfully" + (duet--format-failure-explanation tr)))))) + +;;; Log-record schema + +(ert-deftest test-duet-exec-log-record-schema () + (duet-test--with-clean-engine + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet--transfer-handle-result tr '(:exit 0)) + (let ((rec (duet--transfer-log-record tr))) + (should (= (duet-transfer-id tr) (plist-get rec :id))) + (should (eq 'rsync (plist-get rec :backend))) + (should (eq :local (plist-get rec :route))) + (should (stringp (plist-get rec :argv))) + (should (eq 'done (plist-get rec :status))))))) + +(ert-deftest test-duet-exec-log-record-redacts-argv () + (duet-test--with-clean-engine + (duet-register-backend + (duet-backend-create + :name 'secret-tool + :handles (lambda (_s _d) nil) + :command (lambda (_s _d _o) '(:argv ("x"))) + :redaction '("\\(--password=\\)\\S-+") + :cleanup :none)) + (let ((tr (duet--make-transfer + '(:backend secret-tool :route :local :destination-directory "/dst" + :argv ("tool" "--password=hunter2" "/dst"))))) + (let ((argv (plist-get (duet--transfer-log-record tr) :argv))) + (should (string-match-p "--password=<redacted>" argv)) + (should-not (string-match-p "hunter2" argv)))))) + +;;; Default stray-temp lister (real tmp dir, no subprocess) + +(ert-deftest test-duet-exec-list-stray-temp-files-matches-pattern () + (duet-test--with-clean-engine + (let ((dir (make-temp-file "duet-temp-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name ".a.txt.AbCdEf" dir)) + (write-region "" nil (expand-file-name "a.txt" dir)) + (let* ((tr (duet--make-transfer + (duet-test--argv-spec :destination-directory dir))) + (strays (duet--list-stray-temp-files tr))) + (should (= 1 (length strays))) + (should (string-match-p "\\.a\\.txt\\.AbCdEf\\'" (car strays))))) + (delete-directory dir t))))) + +;;; Thin interactive glue + +(ert-deftest test-duet-exec-submit-builds-and-runs () + (duet-test--with-clean-engine + (let ((tr (duet--submit-transfer '("/src/a.txt") "/dst" nil))) + (should (duet-transfer-p tr)) + (should (eq 'rsync (duet-transfer-backend tr))) + (should (member "/src/a.txt" (plist-get (duet-transfer-spec tr) :sources)))))) + +(ert-deftest test-duet-exec-submit-no-sources-errors () + (duet-test--with-clean-engine + (should-error (duet--submit-transfer nil "/dst" nil) :type 'user-error))) + +(ert-deftest test-duet-copy-and-move-submit-via-engine () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'dired-get-marked-files) (lambda (&rest _) '("/src/a.txt"))) + ((symbol-function 'duet--other-pane) (lambda (&rest _) 'win)) + ((symbol-function 'duet--pane-directory) (lambda (_w) "/dst")) + ((symbol-function 'display-buffer) (lambda (&rest _) nil))) + (duet-copy) + (should (= 1 (length duet--transfers))) + (should-not (duet-transfer-move-p (car duet--transfers))) + (duet-move) + (should (= 2 (length duet--transfers))) + (should (duet-transfer-move-p (car duet--transfers)))))) + +(ert-deftest test-duet-mkdir-creates-and-refreshes () + (duet-test--with-clean-engine + (let ((made nil)) + (cl-letf (((symbol-function 'make-directory) (lambda (d &rest _) (setq made d))) + ((symbol-function 'run-with-timer) (lambda (&rest _) 'fake-timer))) + (let ((default-directory "/work/")) + (duet-mkdir "newdir") + (should (string-match-p "newdir" made)) + (should (member "/work/" duet--refresh-pending))))))) + +(ert-deftest test-duet-delete-trashes-files-and-directories () + "Marked files go through `delete-file' and directories through +`delete-directory', both to trash, then the active pane refreshes." + (duet-test--with-clean-engine + (let ((trashed-files nil) (removed-dirs nil)) + (cl-letf (((symbol-function 'dired-get-marked-files) + (lambda (&rest _) '("/work/a.txt" "/work/sub"))) + ((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'file-directory-p) (lambda (f) (string= f "/work/sub"))) + ((symbol-function 'delete-file) (lambda (f &optional _trash) (push f trashed-files))) + ((symbol-function 'delete-directory) (lambda (d &rest _) (push d removed-dirs))) + ((symbol-function 'run-with-timer) (lambda (&rest _) 'fake-timer))) + (let ((default-directory "/work/")) + (duet-delete) + (should (member "/work/a.txt" trashed-files)) + (should (member "/work/sub" removed-dirs)) + (should (member "/work/" duet--refresh-pending))))))) + +(ert-deftest test-duet-cancel-transfer-command-no-active-errors () + (duet-test--with-clean-engine + (should-error (duet-cancel-transfer) :type 'user-error))) + +(ert-deftest test-duet-cancel-transfer-command-cancels-latest () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'duet--kill-process) #'ignore) + ((symbol-function 'message) (lambda (&rest _) nil))) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (duet-cancel-transfer) + (should (eq 'cancelling (duet-transfer-status tr))))))) + +(ert-deftest test-duet-explain-transfer-failure-no-transfers-errors () + (duet-test--with-clean-engine + (should-error (duet-explain-transfer-failure) :type 'user-error))) + +(ert-deftest test-duet-explain-transfer-failure-shows-buffer () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'display-buffer) (lambda (b &rest _) b))) + (let ((tr (duet--run-transfer (duet-test--argv-spec)))) + (setf (duet-transfer-stderr tr) "rsync: Permission denied (13)") + (duet--transfer-handle-result tr '(:exit 23)) + (duet-explain-transfer-failure) + (with-current-buffer "*DUET Transfer Failure*" + (should (string-match-p "fix-permissions" (buffer-string)))))))) + +;;; Timer-arming and cancellation branches + +(ert-deftest test-duet-exec-arm-stall-timer-when-enabled () + (duet-test--with-clean-engine + (let ((duet-transfer-stall-timeout 60)) + (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) 'armed))) + (let ((tr (duet--make-transfer (duet-test--argv-spec)))) + (duet--arm-stall-timer tr) + (should (eq 'armed (duet-transfer-stall-timer tr)))))))) + +(ert-deftest test-duet-exec-cancel-stall-timer-cancels-real-timer () + (duet-test--with-clean-engine + (let ((tr (duet--make-transfer (duet-test--argv-spec)))) + (setf (duet-transfer-stall-timer tr) (run-with-timer 100 nil #'ignore)) + (duet--cancel-stall-timer tr) + (should (null (duet-transfer-stall-timer tr)))))) + +(ert-deftest test-duet-exec-render-cancels-real-timer () + (duet-test--with-clean-engine + (setq duet--log-render-timer (run-with-timer 100 nil #'ignore)) + (duet--render-transfer-log) + (should (null duet--log-render-timer)))) + +;;; Pane-refresh execution + +(ert-deftest test-duet-exec-do-pane-refresh-clears-pending () + (duet-test--with-clean-engine + (let ((refreshed nil)) + (cl-letf (((symbol-function 'duet--refresh-dir) (lambda (d) (push d refreshed)))) + (setq duet--refresh-pending '("/x/" "/y/") + duet--refresh-timer (run-with-timer 100 nil #'ignore)) + (duet--do-pane-refresh) + (should (null duet--refresh-pending)) + (should (null duet--refresh-timer)) + (should (= 2 (length refreshed))))))) + +(ert-deftest test-duet-exec-refresh-dir-reverts-dired-buffer () + (duet-test--with-clean-engine + (let ((dir (make-temp-file "duet-refresh-" t))) + (unwind-protect + (let ((buf (dired-noselect dir))) + (unwind-protect + (progn + (duet--refresh-dir dir) + (should (buffer-live-p buf))) + (kill-buffer buf))) + (delete-directory dir t))))) + +;;; delete-source on a directory + +(ert-deftest test-duet-exec-delete-source-removes-directory () + (duet-test--with-clean-engine + (let ((dir (make-temp-file "duet-del-" t))) + (should (file-directory-p dir)) + (duet--delete-source dir) + (should-not (file-exists-p dir))))) + +;;; Safety-text variants + +(ert-deftest test-duet-exec-safety-text-variants () + (should (string= "ok" (duet--safety-text "ok"))) + (should (string-match-p "Outcome unverified" (duet--safety-text :generic))) + (should (string-match-p "Unknown" (duet--safety-text 'something-else)))) + +;;; submit with an empty backend registry + +(ert-deftest test-duet-exec-submit-no-backend-errors () + (duet-test--with-clean-engine + (let ((duet--backend-registry nil)) + (should-error (duet--submit-transfer '("/src/a.txt") "/dst" nil) + :type 'user-error)))) + +;;; delete edge cases + +(ert-deftest test-duet-delete-no-files-errors () + (duet-test--with-clean-engine + (cl-letf (((symbol-function 'dired-get-marked-files) (lambda (&rest _) nil))) + (let ((default-directory "/work/")) + (should-error (duet-delete) :type 'user-error))))) + +(provide 'test-duet-transfer-exec) +;;; test-duet-transfer-exec.el ends here diff --git a/tests/test-integration-duet-transfer.el b/tests/test-integration-duet-transfer.el new file mode 100644 index 0000000..3b7bcf6 --- /dev/null +++ b/tests/test-integration-duet-transfer.el @@ -0,0 +1,168 @@ +;;; test-integration-duet-transfer.el --- Real-rsync transfer integration -*- 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: + +;; Integration tests that exercise the whole transfer engine against a real +;; local rsync on temporary directories: file and directory copies, the +;; delete-after-success move, and the failed-move-preserves-source guarantee. +;; +;; Components integrated: +;; - duet--run-transfer / duet--launch-process (real make-process) +;; - rsync (REAL, local, version-independent flags) +;; - duet--transfer-sentinel / duet--process-result / duet--transfer-handle-result +;; - duet--finalize-move (real delete on success) +;; +;; Tagged :slow, so `make test' skips them and `make test-all' runs them. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +(defmacro duet-itest--with-clean-engine (&rest body) + "Run BODY with a fresh engine and the real launcher, cancelling timers after." + (declare (indent 0)) + `(let ((duet--transfer-id-counter 0) + (duet--transfers nil) + (duet--transfer-queue nil) + (duet--log-render-timer nil) + (duet--refresh-pending nil) + (duet--refresh-timer nil) + (duet-transfer-stall-timeout nil) + (duet-max-concurrent-transfers 1)) + (unwind-protect (progn ,@body) + (when (timerp duet--log-render-timer) (cancel-timer duet--log-render-timer)) + (when (timerp duet--refresh-timer) (cancel-timer duet--refresh-timer))))) + +(defun duet-itest--wait (tr &optional timeout) + "Block until transfer TR reaches a terminal status or TIMEOUT seconds pass." + (let ((deadline (+ (float-time) (or timeout 15)))) + (while (and (not (memq (duet-transfer-status tr) duet--terminal-statuses)) + (< (float-time) deadline)) + (accept-process-output (duet-transfer-process tr) 0.05)) + (duet-transfer-status tr))) + +(defun duet-itest--tmpdir () + "Create and return a fresh temporary directory." + (file-name-as-directory (make-temp-file "duet-itest-" t))) + +(defun duet-itest--write (path contents) + "Write CONTENTS into PATH, creating parent directories." + (make-directory (file-name-directory path) t) + (with-temp-file path (insert contents))) + +(ert-deftest test-integration-duet-rsync-copies-file () + :tags '(:slow) + (duet-itest--with-clean-engine + (let* ((src (duet-itest--tmpdir)) + (dst (duet-itest--tmpdir)) + (file (expand-file-name "hello.txt" src))) + (unwind-protect + (progn + (duet-itest--write file "payload\n") + (let ((tr (duet--run-transfer + (duet--transfer-spec (list file) dst)))) + (should (eq 'done (duet-itest--wait tr))) + (should (= 0 (duet-transfer-exit tr))) + (should (file-exists-p (expand-file-name "hello.txt" dst))) + (should (duet-transfer-cleanup-verified tr)))) + (delete-directory src t) + (delete-directory dst t))))) + +(ert-deftest test-integration-duet-rsync-copies-directory () + :tags '(:slow) + (duet-itest--with-clean-engine + (let* ((root (duet-itest--tmpdir)) + (dst (duet-itest--tmpdir)) + (tree (expand-file-name "tree" root))) + (unwind-protect + (progn + (duet-itest--write (expand-file-name "a/one.txt" tree) "1") + (duet-itest--write (expand-file-name "b/two.txt" tree) "2") + (let ((tr (duet--run-transfer + (duet--transfer-spec (list tree) dst)))) + (should (eq 'done (duet-itest--wait tr))) + (should (file-exists-p (expand-file-name "tree/a/one.txt" dst))) + (should (file-exists-p (expand-file-name "tree/b/two.txt" dst))))) + (delete-directory root t) + (delete-directory dst t))))) + +(ert-deftest test-integration-duet-move-deletes-source-on-success () + :tags '(:slow) + (duet-itest--with-clean-engine + (let* ((src (duet-itest--tmpdir)) + (dst (duet-itest--tmpdir)) + (file (expand-file-name "movable.txt" src))) + (unwind-protect + (progn + (duet-itest--write file "move me\n") + (let ((tr (duet--run-transfer + (duet--transfer-spec (list file) dst) t))) + (should (eq 'done (duet-itest--wait tr))) + (should (file-exists-p (expand-file-name "movable.txt" dst))) + (should-not (file-exists-p file)))) + (delete-directory src t) + (delete-directory dst t))))) + +(ert-deftest test-integration-duet-failed-move-preserves-source () + :tags '(:slow) + (when (zerop (user-uid)) + (ert-skip "root bypasses directory permissions")) + (duet-itest--with-clean-engine + (let* ((src (duet-itest--tmpdir)) + (dst (duet-itest--tmpdir)) + (file (expand-file-name "keep.txt" src))) + (unwind-protect + (progn + (duet-itest--write file "must survive\n") + ;; Read+execute only: rsync cannot create files in the destination. + (set-file-modes dst #o500) + (let ((tr (duet--run-transfer + (duet--transfer-spec (list file) dst) t))) + (should (eq 'failed (duet-itest--wait tr))) + (should (/= 0 (duet-transfer-exit tr))) + ;; The copy failed, so the move never deleted the source. + (should (file-exists-p file)))) + (set-file-modes dst #o700) + (delete-directory src t) + (delete-directory dst t))))) + +(ert-deftest test-integration-duet-kill-process-terminates-live () + :tags '(:slow) + (duet-itest--with-clean-engine + (let* ((proc (make-process :name "duet-kill-test" + :command '("sleep" "30") :noquery t)) + (tr (duet-transfer-create :id 1 :process proc))) + (should (process-live-p proc)) + (duet--kill-process tr) + (should-not (process-live-p proc))))) + +(ert-deftest test-integration-duet-process-result-classifies-signal () + :tags '(:slow) + (let ((proc (make-process :name "duet-signal-test" + :command '("sleep" "30") :noquery t))) + (interrupt-process proc) + (let ((deadline (+ (float-time) 5))) + (while (and (process-live-p proc) (< (float-time) deadline)) + (accept-process-output proc 0.05))) + (should (eq 'signal (process-status proc))) + (should (eq :signal (car (duet--process-result proc)))))) + +(provide 'test-integration-duet-transfer) +;;; test-integration-duet-transfer.el ends here |