path: root/tests/test-duet-backend.el

;;; test-duet-backend.el --- Tests for the duet backend registry -*- 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 transport-backend registry, scorer, redaction helper,
;; failure-normalizer interface, and the tiered contract-check functions.
;; The machinery is exercised with fake backends defined here; the concrete
;; rsync/TRAMP backends register in Phase 3 once their command builders exist.
;;
;; Each test rebinds `duet--backend-registry' to nil so registrations never
;; leak between tests (no shared mutable state).

;;; Code:

(require 'test-bootstrap (expand-file-name "test-bootstrap.el"))

(defun test-duet-backend--fake (name score &rest overrides)
  "Build a well-formed fake backend named NAME whose scorer returns SCORE.
OVERRIDES is a plist that wins over the conservative defaults.  It is spliced
ahead of the defaults because cl-defstruct constructors take the leftmost
value for a duplicated keyword."
  (apply #'duet-backend-create
         (append
          overrides
          (list :name name
                :handles (lambda (_src _dst) score)
                :command (lambda (_src _dst _opts)
                           (list :argv (list "echo" (symbol-name name))
                                 :default-directory "/"))
                :capabilities '(:async t)
                :redaction '("\\(password=\\)[^ \n]+")))))

;;; Registry — add, find, replace, order

(ert-deftest test-duet-backend-register-and-find ()
  "A registered backend is retrievable by name."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'alpha 10))
    (should (duet-backend-p (duet-backend-by-name 'alpha)))
    (should (= 1 (length (duet-backends))))))

(ert-deftest test-duet-backend-register-replaces-same-name ()
  "Re-registering a name replaces the prior backend rather than duplicating."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'alpha 10))
    (duet-register-backend (test-duet-backend--fake 'alpha 99))
    (should (= 1 (length (duet-backends))))
    (should (= 99 (funcall (duet-backend-handles (duet-backend-by-name 'alpha))
                           nil nil)))))

(ert-deftest test-duet-backend-register-newest-first ()
  "The most recently registered backend sorts ahead of older ones."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'alpha 10))
    (duet-register-backend (test-duet-backend--fake 'beta 20))
    (should (equal '(beta alpha)
                   (mapcar #'duet-backend-name (duet-backends))))))

;;; Scoring — lowest wins, nil skips, ties break by recency

(ert-deftest test-duet-backend-select-lowest-score-wins ()
  "The backend with the lowest score handles the pair."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'expensive 50))
    (duet-register-backend (test-duet-backend--fake 'cheap 5))
    (should (eq 'cheap (duet-backend-name (duet--select-backend nil nil))))))

(ert-deftest test-duet-backend-select-skips-nil-scorers ()
  "A backend whose scorer returns nil cannot handle the pair and is skipped."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'declines nil))
    (duet-register-backend (test-duet-backend--fake 'handles 30))
    (should (eq 'handles (duet-backend-name (duet--select-backend nil nil))))))

(ert-deftest test-duet-backend-select-none-handles-returns-nil ()
  "When no backend scores the pair, selection returns nil."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'a nil))
    (duet-register-backend (test-duet-backend--fake 'b nil))
    (should (null (duet--select-backend nil nil)))))

(ert-deftest test-duet-backend-select-tie-breaks-by-recency ()
  "Equal scores resolve to the most recently registered backend."
  (let ((duet--backend-registry nil))
    (duet-register-backend (test-duet-backend--fake 'older 10))
    (duet-register-backend (test-duet-backend--fake 'newer 10))
    (should (eq 'newer (duet-backend-name (duet--select-backend nil nil))))))

;;; Redaction

(ert-deftest test-duet-redact-replaces-pattern-matches ()
  "A pattern's secret is redacted while its group-1 label is kept."
  (let ((out (duet--redact "ssh password=hunter2 host=example"
                           '("\\(password=\\)[^ \n]+"))))
    (should (string-match-p "password=<redacted>" out))
    (should-not (string-match-p "hunter2" out))
    (should (string-match-p "host=example" out))))

(ert-deftest test-duet-redact-applies-every-pattern ()
  "Multiple patterns each redact independently."
  (let ((out (duet--redact "token=abc secret=def"
                           '("\\(token=\\)[^ \n]+" "\\(secret=\\)[^ \n]+"))))
    (should-not (string-match-p "abc" out))
    (should-not (string-match-p "def" out))))

(ert-deftest test-duet-redact-no-patterns-returns-input ()
  "With no patterns the text is returned unchanged."
  (should (equal "nothing here" (duet--redact "nothing here" nil))))

(ert-deftest test-duet-redact-none-returns-input ()
  "A backend declaring :none (no secret surface) redacts nothing."
  (should (equal "user@host:/path" (duet--redact "user@host:/path" :none))))

;;; Failure normalizer — minimal mapping and shape

(ert-deftest test-duet-normalize-failure-shape-has-all-keys ()
  "A normalized failure carries class, cause, evidence, safety, next-actions."
  (let ((n (duet--normalize-failure
            (test-duet-backend--fake 'x 1)
            '(:exit 1 :stderr "boom"))))
    (should (plist-member n :class))
    (should (plist-member n :cause))
    (should (plist-member n :evidence))
    (should (plist-member n :safety))
    (should (plist-member n :next-actions))))

(ert-deftest test-duet-normalize-failure-launch-error ()
  "A launch error classifies as launch-failure."
  (let ((n (duet--normalize-failure
            (test-duet-backend--fake 'x 1)
            '(:launch-error "No such file or directory"))))
    (should (eq 'launch-failure (plist-get n :class)))))

(ert-deftest test-duet-normalize-failure-unknown-nonzero-exit ()
  "An unrecognized nonzero exit falls back to backend-unknown-failure."
  (let ((n (duet--normalize-failure
            (test-duet-backend--fake 'x 1)
            '(:exit 42 :stderr "weird"))))
    (should (eq 'backend-unknown-failure (plist-get n :class)))))

;;; Failure-pattern mechanism

(ert-deftest test-duet-failure-patterns-match-by-stderr-regexp ()
  "A pattern whose :match regexp hits stderr supplies its class and cause."
  (let* ((normalizer
          (duet-define-cli-failure-patterns
           '((:match "Permission denied" :class permission-denied
                     :cause "The destination rejected the write."
                     :next-actions (fix-permissions)
                     :safety "Source unchanged."))))
         (n (funcall normalizer '(:exit 23 :stderr "rsync: Permission denied (13)"))))
    (should (eq 'permission-denied (plist-get n :class)))
    (should (equal '(fix-permissions) (plist-get n :next-actions)))))

(ert-deftest test-duet-failure-patterns-fall-back-to-minimal ()
  "When no pattern matches, the normalizer falls back to the minimal mapping."
  (let* ((normalizer
          (duet-define-cli-failure-patterns
           '((:match "Permission denied" :class permission-denied
                     :cause "..." :next-actions (fix-permissions)))))
         (n (funcall normalizer '(:exit 99 :stderr "totally different"))))
    (should (eq 'backend-unknown-failure (plist-get n :class)))))

(ert-deftest test-duet-normalize-failure-uses-backend-normalizer ()
  "A backend carrying a normalizer has it consulted before the minimal mapping."
  (let* ((normalizer
          (duet-define-cli-failure-patterns
           '((:match "rate" :class rate-limited :cause "Throttled."
                     :next-actions (retry-later)))))
         (backend (test-duet-backend--fake 'cloud 1 :normalizer normalizer))
         (n (duet--normalize-failure backend '(:exit 1 :stderr "API rate exceeded"))))
    (should (eq 'rate-limited (plist-get n :class)))))

(ert-deftest test-duet-normalize-failure-minimal-branches ()
  "The minimal normalizer maps each generic failure context to its class."
  (let ((b (test-duet-backend--fake 'x 1)))
    (should (eq 'missing-executable
               (plist-get (duet--normalize-failure b '(:executable-missing t)) :class)))
    (should (eq 'stalled
               (plist-get (duet--normalize-failure b '(:timeout t)) :class)))
    (should (eq 'cancelled
               (plist-get (duet--normalize-failure b '(:signal 9)) :class)))
    (should (eq 'backend-unknown-failure
               (plist-get (duet--normalize-failure b '(:stderr "no exit code")) :class)))))

(ert-deftest test-duet-failure-patterns-predicate-match ()
  "A :match predicate (not a regexp) is called with the whole context."
  (let* ((norm (duet-define-cli-failure-patterns
                (list (list :match (lambda (ctx) (eq 99 (plist-get ctx :exit)))
                            :class 'special :cause "x" :next-actions '(retry)))))
         (n (funcall norm '(:exit 99 :stderr ""))))
    (should (eq 'special (plist-get n :class)))))

(ert-deftest test-duet-redact-whole-match-without-group ()
  "A pattern with no capture group redacts the whole match."
  (should (equal "<redacted>" (duet--redact "secretvalue" '("secret[a-z]+")))))

(ert-deftest test-duet-backend-check-capability-flags-undeclared ()
  "A capability asserted but absent from `capabilities' is flagged."
  (let ((b (test-duet-backend--fake
            'cap 10 :cleanup :none
            :normalizer (duet-define-cli-failure-patterns nil))))
    (should (cl-some (lambda (s) (string-match-p "resume" s))
                     (duet-backend-check-capability b :resume)))))

(ert-deftest test-duet-backend-check-capability-passes-declared ()
  "A declared capability on an otherwise-publishable backend passes."
  (let ((b (test-duet-backend--fake
            'cap 10 :cleanup :none :capabilities '(:resume t)
            :normalizer (duet-define-cli-failure-patterns nil))))
    (should (null (duet-backend-check-capability b :resume)))))

;;; Contract checks — tiered

(ert-deftest test-duet-backend-check-minimum-passes-clean-backend ()
  "A well-formed fake backend reports no minimum-tier violations."
  (should (null (duet-backend-check-minimum (test-duet-backend--fake 'good 10)))))

(ert-deftest test-duet-backend-check-minimum-flags-missing-redaction ()
  "A backend that declares no redaction metadata fails the minimum tier."
  (let ((b (test-duet-backend--fake 'noredact 10 :redaction nil)))
    (should (duet-backend-check-minimum b))))

(ert-deftest test-duet-backend-check-minimum-accepts-none-redaction ()
  "A backend with no secret surface declares :none and passes the minimum tier."
  (let ((b (test-duet-backend--fake 'localonly 10 :redaction :none)))
    (should (null (duet-backend-check-minimum b)))))

(ert-deftest test-duet-backend-check-minimum-flags-shell-string-command ()
  "A command builder returning a shell string instead of an argv list fails."
  (let ((b (test-duet-backend--fake 'shellish 10
                                    :command (lambda (_s _d _o)
                                               (list :shell-command "rm -rf /")))))
    (should (duet-backend-check-minimum b))))

(ert-deftest test-duet-backend-check-minimum-flags-nil-command-spec ()
  "A command builder returning nil fails the minimum tier (nil is a list)."
  (let ((b (test-duet-backend--fake 'nilcmd 10 :command (lambda (_s _d _o) nil))))
    (should (duet-backend-check-minimum b))))

(ert-deftest test-duet-backend-check-minimum-flags-empty-argv-cli ()
  "A CLI backend with nil argv and no declared in-process mode fails."
  (let ((b (test-duet-backend--fake
            'noargv 10
            :command (lambda (_s _d _o) (list :argv nil :default-directory "/")))))
    (should (duet-backend-check-minimum b))))

(ert-deftest test-duet-backend-check-minimum-accepts-in-process-spec ()
  "A backend declaring an in-process mode (:tramp) passes with a nil argv."
  (let ((b (test-duet-backend--fake
            'inproc 10
            :command (lambda (_s _d _o) (list :argv nil :tramp t)))))
    (should (null (duet-backend-check-minimum b)))))

(ert-deftest test-duet-backend-check-minimum-flags-non-string-argv ()
  "An argv carrying non-string elements is not a runnable CLI command."
  (let ((b (test-duet-backend--fake
            'bad 10
            :command (lambda (_s _d _o) (list :argv '("rsync" 42))))))
    (should (duet-backend-check-minimum b))))

(ert-deftest test-duet-backend-check-publishable-flags-missing-cleanup ()
  "The publishable tier additionally requires declared cleanup semantics."
  (let ((b (test-duet-backend--fake 'pub 10
                                    :normalizer (duet-define-cli-failure-patterns nil))))
    ;; cleanup slot is unset, so publishable must flag it even though minimum passes.
    (should (null (duet-backend-check-minimum b)))
    (should (duet-backend-check-publishable b))))

(ert-deftest test-duet-backend-check-publishable-includes-minimum ()
  "Publishable problems are a superset of the minimum-tier problems."
  (let* ((b (test-duet-backend--fake 'broken 10 :redaction nil))
         (min (duet-backend-check-minimum b))
         (pub (duet-backend-check-publishable b)))
    (should min)
    (should (cl-every (lambda (p) (member p pub)) min))))

(provide 'test-duet-backend)
;;; test-duet-backend.el ends here