etaf/etaf-render-port.el

;;; etaf-render-port.el --- Versioned Ebox renderer port -*- lexical-binding: t; -*-

;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;; This file is ETAF's only Ebox framework-SPI bootstrap owner.  It probes the
;; additive Ebox v2 provider once, selects one immutable port, and exposes that
;; selection to downstream ETAF code without repeated `featurep' or `fboundp'
;; protocol guesses.  A completely absent v2 provider receives a complete v1
;; fallback; a present but broken or incompatible provider fails closed.

;;; Code:

(require 'cl-lib)
(require 'subr-x)
(require 'ebox)

(define-error 'etaf-spi-bootstrap-error
  "Malformed Ebox framework SPI provider")
(define-error 'etaf-spi-incompatible-error
  "Incompatible Ebox framework SPI provider"
  'etaf-spi-bootstrap-error)

(defconst etaf-render-port--required-spi-version 2
  "Ebox framework SPI version consumed by this ETAF build.")

(defconst etaf-render-port--required-schema-version
  'ebox-framework-spi-schema/v2
  "Ebox provider schema consumed by this ETAF build.")

(defconst etaf-render-port--required-capabilities
  '(initial-paired-stage-rollback
    update-paired-stage-rollback
    combined-participant-ordering
    same-object-legacy-report)
  "Capabilities required from an Ebox framework SPI v2 provider.")

(defconst etaf-render-port--required-tp-protocol
  'tp-transaction-protocol-v1+v2
  "TP transaction protocol required by the Ebox framework SPI.")

(defconst etaf-render-port--required-stage-order
  '(ebox-mirror/native framework-stage)
  "Required stage order inside the combined Ebox participant.")

(defconst etaf-render-port--required-rollback-order
  '(framework-rollback ebox-mirror/native tp)
  "Required rollback order inside the combined Ebox participant.")

(cl-defstruct
    (etaf-render-port
     (:constructor etaf-render-port--create)
     (:conc-name etaf-render-port--))
  "Immutable selected Ebox rendering capability."
  (route nil :read-only t)
  (spi-version nil :read-only t)
  (schema-version nil :read-only t)
  (capabilities nil :read-only t)
  (tp-protocol nil :read-only t)
  (initial-function nil :read-only t)
  (update-function nil :read-only t)
  (bootstrap-outcome nil :read-only t)
  (provider nil :read-only t))

(defun etaf-render-port-route (port)
  "Return selected PORT route, either `v1' or `v2'."
  (etaf-render-port--route port))

(defun etaf-render-port-spi-version (port)
  "Return PORT's selected framework SPI version."
  (etaf-render-port--spi-version port))

(defun etaf-render-port-schema-version (port)
  "Return PORT's selected provider schema version."
  (etaf-render-port--schema-version port))

(defun etaf-render-port-capabilities (port)
  "Return a defensive copy of PORT's capabilities."
  (copy-sequence (etaf-render-port--capabilities port)))

(defun etaf-render-port-tp-protocol (port)
  "Return PORT's selected TP transaction protocol."
  (etaf-render-port--tp-protocol port))

(defun etaf-render-port-initial-function (port)
  "Return PORT's initial mount function symbol."
  (etaf-render-port--initial-function port))

(defun etaf-render-port-update-function (port)
  "Return PORT's update function symbol."
  (etaf-render-port--update-function port))

(defun etaf-render-port-bootstrap-outcome (port)
  "Return PORT's immutable bootstrap outcome tag."
  (etaf-render-port--bootstrap-outcome port))

(defun etaf-render-port--bootstrap-error (reason &optional detail)
  "Signal a fail-closed bootstrap error for REASON and DETAIL."
  (signal 'etaf-spi-bootstrap-error
          (list :reason reason :detail detail)))

(defun etaf-render-port--ensure-accessors ()
  "Require every public Ebox v2 record accessor before reading a provider."
  (dolist
      (function
       '(ebox-framework-spi-provider-p
         ebox-framework-spi-provider-spi-version
         ebox-framework-spi-provider-schema-version
         ebox-framework-spi-provider-capabilities
         ebox-framework-spi-provider-tp-protocol
         ebox-framework-spi-provider-stage-order
         ebox-framework-spi-provider-rollback-order
         ebox-framework-spi-provider-report-semantics
         ebox-framework-spi-provider-initial-operation
         ebox-framework-spi-provider-update-operation
         ebox-framework-spi-operation-p
         ebox-framework-spi-operation-kind
         ebox-framework-spi-operation-function
         ebox-framework-spi-operation-argument-schema
         ebox-framework-spi-operation-result-schema
         ebox-framework-spi-operation-paired-stage-rollback-p))
    (unless (fboundp function)
      (etaf-render-port--bootstrap-error
       'missing-provider-accessor function))))

(defun etaf-render-port--operation-snapshot (operation label)
  "Return validated immutable field snapshot for OPERATION named LABEL."
  (unless (ebox-framework-spi-operation-p operation)
    (etaf-render-port--bootstrap-error
     'malformed-operation (list :label label :value operation)))
  (let ((kind (ebox-framework-spi-operation-kind operation))
        (function (ebox-framework-spi-operation-function operation))
        (arguments
         (ebox-framework-spi-operation-argument-schema operation))
        (result (ebox-framework-spi-operation-result-schema operation))
        (paired
         (ebox-framework-spi-operation-paired-stage-rollback-p operation)))
    (unless (and (symbolp kind)
                 (symbolp function)
                 (fboundp function)
                 (proper-list-p arguments)
                 (cl-every #'symbolp arguments)
                 (symbolp result)
                 (memq paired '(nil t)))
      (etaf-render-port--bootstrap-error
       'malformed-operation-fields
       (list :label label :kind kind :function function
             :arguments arguments :result result :paired paired)))
    (list :kind kind :function function
          :arguments (copy-sequence arguments)
          :result result :paired paired)))

(defun etaf-render-port--provider-snapshot (provider)
  "Return a validated field snapshot of Ebox v2 PROVIDER."
  (etaf-render-port--ensure-accessors)
  (unless (ebox-framework-spi-provider-p provider)
    (etaf-render-port--bootstrap-error 'non-provider-record provider))
  (let ((spi-version (ebox-framework-spi-provider-spi-version provider))
        (schema-version
         (ebox-framework-spi-provider-schema-version provider))
        (capabilities
         (ebox-framework-spi-provider-capabilities provider))
        (tp-protocol (ebox-framework-spi-provider-tp-protocol provider))
        (stage-order (ebox-framework-spi-provider-stage-order provider))
        (rollback-order
         (ebox-framework-spi-provider-rollback-order provider))
        (report-semantics
         (ebox-framework-spi-provider-report-semantics provider)))
    (unless (and (integerp spi-version)
                 (> spi-version 0)
                 (symbolp schema-version)
                 (proper-list-p capabilities)
                 (cl-every #'symbolp capabilities)
                 (symbolp tp-protocol)
                 (proper-list-p stage-order)
                 (cl-every #'symbolp stage-order)
                 (proper-list-p rollback-order)
                 (cl-every #'symbolp rollback-order)
                 (symbolp report-semantics))
      (etaf-render-port--bootstrap-error
       'malformed-provider-fields
       (list :spi-version spi-version :schema-version schema-version
             :capabilities capabilities :tp-protocol tp-protocol
             :stage-order stage-order :rollback-order rollback-order
             :report-semantics report-semantics)))
    (list
     :provider provider
     :spi-version spi-version
     :schema-version schema-version
     :capabilities (copy-sequence capabilities)
     :tp-protocol tp-protocol
     :stage-order (copy-sequence stage-order)
     :rollback-order (copy-sequence rollback-order)
     :report-semantics report-semantics
     :initial
     (etaf-render-port--operation-snapshot
      (ebox-framework-spi-provider-initial-operation provider) 'initial)
     :update
     (etaf-render-port--operation-snapshot
      (ebox-framework-spi-provider-update-operation provider) 'update))))

(defun etaf-render-port--incompatibilities (snapshot)
  "Return deterministic compatibility failures in provider SNAPSHOT."
  (let (failures)
    (unless (eql (plist-get snapshot :spi-version)
                 etaf-render-port--required-spi-version)
      (push (list :spi-version (plist-get snapshot :spi-version)) failures))
    (unless (eq (plist-get snapshot :schema-version)
                etaf-render-port--required-schema-version)
      (push (list :schema-version (plist-get snapshot :schema-version))
            failures))
    (let ((capabilities (plist-get snapshot :capabilities)))
      (dolist (capability etaf-render-port--required-capabilities)
        (unless (memq capability capabilities)
          (push (list :missing-capability capability) failures))))
    (unless (eq (plist-get snapshot :tp-protocol)
                etaf-render-port--required-tp-protocol)
      (push (list :tp-protocol (plist-get snapshot :tp-protocol)) failures))
    (unless (equal (plist-get snapshot :stage-order)
                   etaf-render-port--required-stage-order)
      (push (list :stage-order (plist-get snapshot :stage-order)) failures))
    (unless (equal (plist-get snapshot :rollback-order)
                   etaf-render-port--required-rollback-order)
      (push (list :rollback-order (plist-get snapshot :rollback-order))
            failures))
    (unless (eq (plist-get snapshot :report-semantics)
                'same-object-legacy-report)
      (push (list :report-semantics
                  (plist-get snapshot :report-semantics))
            failures))
    (dolist
        (expectation
         `((:initial initial ebox-framework-spi-initial
                    (buffer canonical-input framework-stage framework-rollback))
           (:update update ebox-framework-spi-update
                    (buffer canonical-input-or-candidate
                            framework-stage framework-rollback))))
      (let* ((slot (nth 0 expectation))
             (operation (plist-get snapshot slot)))
        (unless (and (eq (plist-get operation :kind) (nth 1 expectation))
                     (eq (plist-get operation :function) (nth 2 expectation))
                     (equal (plist-get operation :arguments)
                            (nth 3 expectation))
                     (eq (plist-get operation :result)
                         'ebox-legacy-report/same-object)
                     (eq (plist-get operation :paired) t))
          (push (list slot operation) failures))))
    (nreverse failures)))

(defun etaf-render-port--validate-framework-pair
    (framework-stage framework-rollback)
  "Validate FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK as one required pair."
  (unless (functionp framework-stage)
    (signal 'wrong-type-argument (list 'functionp framework-stage)))
  (unless (functionp framework-rollback)
    (signal 'wrong-type-argument (list 'functionp framework-rollback)))
  t)

(defun etaf-render-port--v1-initial
    (buffer input framework-stage framework-rollback)
  "Publish INPUT initially to BUFFER through legacy Ebox.
FRAMEWORK-STAGE runs after publication; FRAMEWORK-ROLLBACK performs contained
manual framework cleanup if staging fails."
  (etaf-render-port--validate-framework-pair
   framework-stage framework-rollback)
  (let ((result (ebox-render-to-buffer buffer input))
        stage-entered)
    (condition-case primary
        (progn
          (setq stage-entered t)
          (funcall framework-stage nil)
          result)
      ((error quit)
       (when stage-entered
         (let ((inhibit-quit t) (quit-flag nil))
           (condition-case nil
               (funcall framework-rollback nil)
             ((error quit) nil))))
       (signal (car primary) (cdr primary))))))

(defun etaf-render-port--v1-update
    (buffer input framework-stage framework-rollback)
  "Update BUFFER from INPUT through the legacy Ebox callback pair.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
  (etaf-render-port--validate-framework-pair
   framework-stage framework-rollback)
  (ebox-commit buffer input framework-stage framework-rollback))

(defun etaf-render-port--v1-fallback ()
  "Return the complete immutable fallback port for an absent Ebox v2 SPI."
  (etaf-render-port--create
   :route 'v1
   :spi-version 1
   :schema-version 'etaf-ebox-v1-fallback/v1
   :capabilities
   '(initial-manual-cleanup update-paired-stage-rollback
     same-object-update-report)
   :tp-protocol 'tp-transaction-protocol-v1
   :initial-function 'etaf-render-port--v1-initial
   :update-function 'etaf-render-port--v1-update
   :bootstrap-outcome 'v2-absent-v1-selected))

(defun etaf-render-port--v2-port (snapshot)
  "Return an immutable selected v2 port from compatible SNAPSHOT."
  (let ((failures (etaf-render-port--incompatibilities snapshot)))
    (when failures
      (signal 'etaf-spi-incompatible-error
              (list :incompatibilities failures)))
    (etaf-render-port--create
     :route 'v2
     :spi-version (plist-get snapshot :spi-version)
     :schema-version (plist-get snapshot :schema-version)
     :capabilities (copy-sequence (plist-get snapshot :capabilities))
     :tp-protocol (plist-get snapshot :tp-protocol)
     :initial-function
     (plist-get (plist-get snapshot :initial) :function)
     :update-function
     (plist-get (plist-get snapshot :update) :function)
     :bootstrap-outcome 'valid-v2-selected
     :provider (plist-get snapshot :provider))))

(defun etaf-render-port--bootstrap ()
  "Probe Ebox exactly once and return one immutable selected render port."
  (let ((feature-present-p (featurep 'ebox-framework-spi-v2))
        (predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
    (cond
     ((and (not feature-present-p) (not predicate-present-p))
      (etaf-render-port--v1-fallback))
     ((not feature-present-p)
      (etaf-render-port--bootstrap-error 'predicate-without-v2-feature))
     ((not predicate-present-p)
      (etaf-render-port--bootstrap-error 'v2-feature-without-predicate))
     (t
      (condition-case condition
          (etaf-render-port--v2-port
           (etaf-render-port--provider-snapshot
            (ebox-framework-spi-capabilities)))
        ((etaf-spi-incompatible-error etaf-spi-bootstrap-error)
         (signal (car condition) (cdr condition)))
        ((error quit)
         (etaf-render-port--bootstrap-error
          'provider-predicate-failure condition)))))))

(defconst etaf-render-port--selected-port
  (etaf-render-port--bootstrap)
  "Process-wide immutable Ebox render port selected during ETAF bootstrap.")

(defun etaf-render-port-selected ()
  "Return the process-wide immutable Ebox render port."
  etaf-render-port--selected-port)

(defun etaf-render-port-initial
    (buffer input framework-stage framework-rollback)
  "Run selected initial operation for BUFFER and canonical INPUT.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
  (funcall (etaf-render-port-initial-function
            etaf-render-port--selected-port)
           buffer input framework-stage framework-rollback))

(defun etaf-render-port-update
    (buffer input framework-stage framework-rollback)
  "Run selected update operation for BUFFER and INPUT.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
  (funcall (etaf-render-port-update-function
            etaf-render-port--selected-port)
           buffer input framework-stage framework-rollback))

(provide 'etaf-render-port)

;;; etaf-render-port.el ends here