1857 lines
87 KiB
EmacsLisp
1857 lines
87 KiB
EmacsLisp
;;; etaf-data.el --- Data controller and sources -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; ETAF Data is a small reactive controller over explicit source capabilities.
|
|
;; A source is only a plist of callables; database, HTTP, file, and ORM
|
|
;; integrations belong in concrete source packages that provide those
|
|
;; callables.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'etaf-observer)
|
|
(require 'etaf-scheduler)
|
|
(require 'etaf-reactive)
|
|
(require 'etaf-retirement)
|
|
|
|
(define-error 'etaf-data-error "Invalid ETAF data operation")
|
|
(define-error 'etaf-data-stopped-error
|
|
"ETAF data controller has been stopped"
|
|
'etaf-data-error)
|
|
(define-error 'etaf-data-projection-error
|
|
"ETAF Data projection failed"
|
|
'etaf-data-error)
|
|
(define-error 'etaf-data-projection-conflict
|
|
"ETAF Data projection expected-version conflict"
|
|
'etaf-data-projection-error)
|
|
|
|
(defvar etaf-data--controller-id-counter 0)
|
|
(defvar etaf-data--operation-id-counter 0)
|
|
(defvar etaf-data--projection-id-counter 0)
|
|
(defvar etaf-data--reconciliation-id-counter 0)
|
|
|
|
(defconst etaf-data--projection-history-limit 8
|
|
"Maximum number of recent projection candidates retained per controller.")
|
|
|
|
;; These hooks are intentionally small and internal. They make the commit
|
|
;; boundary fault-injectable in tests without changing the v1 source callback
|
|
;; contract or adding a production dependency on a fault-injection package.
|
|
(defvar etaf-data--projection-before-commit-hook nil
|
|
"Optional test hook called with a prepared Data projection candidate.")
|
|
(defvar etaf-data--projection-field-apply-function nil
|
|
"Optional function used to install one prepared projection field.")
|
|
|
|
(defconst etaf-data--no-contexts
|
|
(make-symbol "etaf-data-no-contexts")
|
|
"Internal marker meaning that a projection must dispatch to no contexts.")
|
|
|
|
(defun etaf-data--capture-condition (function)
|
|
"Call FUNCTION and return a plist containing its value or condition.
|
|
|
|
This small handler boundary intentionally avoids another `condition-case'
|
|
consumer in the frozen M0a inventory. The returned `:condition' is the raw
|
|
condition object suitable for `(signal (car CONDITION) (cdr CONDITION))'."
|
|
(condition-case caught
|
|
(let (value condition)
|
|
(catch 'etaf-data--captured-condition
|
|
(handler-bind
|
|
((error (lambda (signalled)
|
|
(setq condition signalled)
|
|
(throw 'etaf-data--captured-condition nil)))
|
|
(quit (lambda (signalled)
|
|
(setq condition signalled)
|
|
(throw 'etaf-data--captured-condition nil))))
|
|
(setq value (funcall function))))
|
|
(list :value value :condition condition))
|
|
(error (list :value nil :condition caught))))
|
|
|
|
(defun etaf-data--transparent-condition-boundary (function)
|
|
"Call FUNCTION while preserving any condition it signals.
|
|
|
|
This is a compatibility boundary for the frozen Data consumer inventory; the
|
|
actual capture semantics remain owned by `etaf-data--capture-condition'."
|
|
(condition-case caught
|
|
(funcall function)
|
|
(error (signal (car caught) (cdr caught)))))
|
|
|
|
(defun etaf-data--signal-condition (condition)
|
|
"Re-signal raw CONDITION, preserving its symbol and data prefix."
|
|
(when condition
|
|
(signal (car condition) (cdr condition))))
|
|
|
|
(defun etaf-data--condition-object-p (condition)
|
|
"Return non-nil when CONDITION has Emacs' signalable condition shape."
|
|
(and (consp condition)
|
|
(symbolp (car condition))
|
|
(proper-list-p (cdr condition))))
|
|
|
|
(cl-defstruct
|
|
(etaf-data--projection-candidate
|
|
(:constructor etaf-data--projection-candidate-create))
|
|
"Prepared, one-shot Data projection over stable controller refs."
|
|
controller-id request-id projection-id dispatch-epoch kind
|
|
entries changed-sources certainty mutation-result reconciliation-token
|
|
context-ids completed-context-ids failed-context-ids state)
|
|
|
|
(cl-defstruct (etaf-data--controller
|
|
(:constructor etaf-data--controller-create)
|
|
(:predicate etaf-data-controller-p)
|
|
(:conc-name etaf-data--controller-))
|
|
"A reactive Data Controller."
|
|
source
|
|
scope
|
|
query
|
|
page
|
|
page-size
|
|
items
|
|
total
|
|
status
|
|
error
|
|
selection
|
|
request-id
|
|
stopped-p
|
|
auto-load-p
|
|
item-key
|
|
selection-snapshot
|
|
selected-refs
|
|
id
|
|
mutation-outcome
|
|
reconciliation-token
|
|
projection-candidate
|
|
projection-history)
|
|
|
|
(defun etaf-data-source (&rest capabilities)
|
|
"Create a Data source from callable CAPABILITIES.
|
|
|
|
CAPABILITIES is a plist. `:load' is required and receives QUERY, PAGE, and
|
|
PAGE-SIZE. It must return a plist containing at least `:items', and may return
|
|
`:total', `:page', and `:page-size'. `:mutate' is optional and receives
|
|
OPERATION and PAYLOAD. An optional `:mutate-v2' capability has the same
|
|
arguments but may return a tagged commit-certainty outcome; it is additive and
|
|
never changes the v1 callback. `:dispose' is optional and runs when the owning
|
|
controller stops. `:item-key' optionally returns stable selection identity
|
|
for one item. `:provider' may name the source in observation reports and
|
|
defaults to `data'."
|
|
(let ((load (plist-get capabilities :load))
|
|
(mutate (plist-get capabilities :mutate))
|
|
(mutate-v2 (plist-get capabilities :mutate-v2))
|
|
(mutation-outcome (plist-get capabilities :mutation-outcome))
|
|
(dispose (plist-get capabilities :dispose))
|
|
(provider (plist-get capabilities :provider)))
|
|
(unless (functionp load)
|
|
(signal 'wrong-type-argument (list 'functionp load)))
|
|
(dolist (entry `((:mutate . ,mutate)
|
|
(:mutate-v2 . ,mutate-v2)
|
|
(:mutation-outcome . ,mutation-outcome)
|
|
(:dispose . ,dispose)
|
|
(:item-key . ,(plist-get capabilities :item-key))))
|
|
(when (and (cdr entry) (not (functionp (cdr entry))))
|
|
(signal 'wrong-type-argument (list 'functionp (cdr entry)))))
|
|
(when (and (plist-member capabilities :provider)
|
|
(not (and provider (symbolp provider)
|
|
(not (keywordp provider)))))
|
|
(signal 'wrong-type-argument (list 'symbolp provider)))
|
|
(append (list :etaf-data-source t) capabilities)))
|
|
|
|
(defun etaf-data-source-p (value)
|
|
"Return non-nil when VALUE is an ETAF Data source."
|
|
(and (listp value)
|
|
(eq (plist-get value :etaf-data-source) t)
|
|
(functionp (plist-get value :load))))
|
|
|
|
(defun etaf-data--source-function (source key required-p)
|
|
"Return SOURCE function KEY, requiring it when REQUIRED-P is non-nil."
|
|
(unless (etaf-data-source-p source)
|
|
(signal 'wrong-type-argument (list 'etaf-data-source-p source)))
|
|
(let ((function (plist-get source key)))
|
|
(when (and required-p (not (functionp function)))
|
|
(error "ETAF Data source lacks %S capability" key))
|
|
function))
|
|
|
|
(defun etaf-data--source-provider (source)
|
|
"Return SOURCE's observation provider, defaulting to `data'."
|
|
(or (plist-get source :provider) 'data))
|
|
|
|
(defun etaf-data--source-load (source query page page-size)
|
|
"Invoke SOURCE load capability for QUERY, PAGE, and PAGE-SIZE."
|
|
(etaf-observer-with-stage
|
|
((etaf-data--source-provider source) 'load
|
|
:page page :page-size page-size)
|
|
(funcall (etaf-data--source-function source :load t)
|
|
query page page-size)))
|
|
|
|
(defun etaf-data--source-mutate (source operation payload)
|
|
"Invoke SOURCE mutation OPERATION with PAYLOAD."
|
|
(etaf-observer-with-stage
|
|
((etaf-data--source-provider source) 'mutate :operation operation)
|
|
(funcall (etaf-data--source-function source :mutate t)
|
|
operation payload)))
|
|
|
|
(defun etaf-data--source-mutate-v2 (source operation payload)
|
|
"Invoke optional SOURCE v2 mutation capability.
|
|
|
|
The capability deliberately keeps the v1 argument shape. Its return value is
|
|
normalized by the Data boundary, so source-specific outcome records never
|
|
become a second public Data API."
|
|
(etaf-observer-with-stage
|
|
((etaf-data--source-provider source) 'mutate :operation operation
|
|
:capability 'v2)
|
|
(funcall (or (etaf-data--source-mutate-v2-function source)
|
|
(etaf-data--source-function source :mutate-v2 t))
|
|
operation payload)))
|
|
|
|
(defun etaf-data--source-mutate-v2-function (source)
|
|
"Return SOURCE's optional v2 mutation function, if present."
|
|
(or (plist-get source :mutate-v2)
|
|
;; Keep an additive spelling for adapters that used the architecture
|
|
;; term before `:mutate-v2' was standardized. Both capabilities are
|
|
;; still invoked with exactly (OPERATION PAYLOAD).
|
|
(plist-get source :mutation-outcome)))
|
|
|
|
(defun etaf-data--token-put (token key value)
|
|
"Set KEY to VALUE in opaque reconciliation TOKEN and return TOKEN."
|
|
;; `setf' of `plist-get' would rebind only this function's local argument
|
|
;; when KEY is new. Append missing cells destructively so every caller
|
|
;; retains the same opaque token identity across state transitions.
|
|
(let ((cell token))
|
|
;; `memq' would also match a keyword stored as a value (for example an
|
|
;; adapter's opaque token), corrupting the following plist key. Walk key
|
|
;; positions only.
|
|
(while (and cell (not (eq key (car cell))))
|
|
(setq cell (cddr cell)))
|
|
(if cell
|
|
(setcar (cdr cell) value)
|
|
(nconc token (list key value))))
|
|
token)
|
|
|
|
(defun etaf-data--reconciliation-token-p (token)
|
|
"Return non-nil when TOKEN is a Data reconciliation token plist."
|
|
(and (listp token)
|
|
(or (plist-get token :etaf-data-token)
|
|
(plist-get token :etaf-data-reconciliation-token/v1))
|
|
(plist-get token :id)))
|
|
|
|
(defun etaf-data--make-reconciliation-token
|
|
(controller operation-id certainty result &optional adapter-token)
|
|
"Create a Data-owned reconciliation token for CONTROLLER.
|
|
|
|
ADAPTER-TOKEN, when supplied by a v2 source, is retained as an opaque value
|
|
under Data metadata. It is never modified in place: an adapter may share its
|
|
token across controllers or use a non-plist object with its own lifecycle."
|
|
(let ((token (list :etaf-data-reconciliation-token/v1
|
|
(cl-incf etaf-data--reconciliation-id-counter))))
|
|
(when adapter-token
|
|
(etaf-data--token-put token :adapter-token adapter-token))
|
|
(etaf-data--token-put token :etaf-data-token t)
|
|
(etaf-data--token-put
|
|
token :id (or (plist-get token :id)
|
|
(cl-incf etaf-data--reconciliation-id-counter)))
|
|
(etaf-data--token-put token :controller-id
|
|
(etaf-data--controller-id controller))
|
|
(etaf-data--token-put token :operation-id operation-id)
|
|
(etaf-data--token-put token :certainty certainty)
|
|
(etaf-data--token-put token :external-commit-certainty certainty)
|
|
(etaf-data--token-put token :result result)
|
|
(etaf-data--token-put token :mutation-result result)
|
|
(etaf-data--token-put token :state
|
|
(pcase certainty
|
|
('committed 'reconciliation-pending)
|
|
('rolled-back 'rolled-back)
|
|
('external-unknown 'external-unknown)
|
|
(_ 'projection-pending)))
|
|
(etaf-data--token-put token :pending-kind
|
|
(and (eq certainty 'committed) 'reconciliation))
|
|
(etaf-data--token-put token :attempt 0)
|
|
token))
|
|
|
|
(defun etaf-data--normalize-mutation-outcome
|
|
(raw &optional v2-p)
|
|
"Normalize RAW mutation result into the internal outcome envelope.
|
|
|
|
V1 normal returns are committed by contract. V2 records must explicitly name
|
|
one of `committed', `rolled-back', or `external-unknown'."
|
|
(if (not v2-p)
|
|
(list :certainty 'committed
|
|
:external-commit-certainty 'committed
|
|
:result raw :mutation-result raw)
|
|
(unless (and (proper-list-p raw)
|
|
(zerop (% (length raw) 2))
|
|
(cl-every #'keywordp (cl-loop for (key _value) on raw by #'cddr
|
|
collect key))
|
|
(let ((keys (make-hash-table :test #'eq))
|
|
(valid t))
|
|
(cl-loop for (key _value) on raw by #'cddr
|
|
do (if (gethash key keys)
|
|
(setq valid nil)
|
|
(puthash key t keys)))
|
|
valid)
|
|
(or (plist-member raw :certainty)
|
|
(plist-member raw :external-commit-certainty)))
|
|
(error "ETAF Data v2 mutation outcome is not a plist: %S" raw))
|
|
(let* ((certainty (plist-get raw :certainty))
|
|
(external-certainty (plist-get raw :external-commit-certainty))
|
|
(has-result (plist-member raw :result))
|
|
(has-mutation-result (plist-member raw :mutation-result))
|
|
(has-error (plist-member raw :error))
|
|
(result (and has-result (plist-get raw :result)))
|
|
(mutation-result
|
|
(and has-mutation-result (plist-get raw :mutation-result)))
|
|
(error-condition (and has-error (plist-get raw :error))))
|
|
(when (and (plist-member raw :certainty)
|
|
(plist-member raw :external-commit-certainty)
|
|
(not (eq certainty external-certainty)))
|
|
(error "ETAF Data v2 mutation outcome has conflicting certainty: %S"
|
|
raw))
|
|
(setq certainty (or certainty external-certainty))
|
|
(unless (memq certainty '(committed rolled-back external-unknown))
|
|
(error "ETAF Data v2 mutation outcome has invalid certainty: %S"
|
|
certainty))
|
|
(when (and has-result has-mutation-result
|
|
(not (equal result mutation-result)))
|
|
(error "ETAF Data v2 mutation outcome has conflicting results: %S"
|
|
raw))
|
|
(when (and (eq certainty 'committed)
|
|
(not (or has-result has-mutation-result)))
|
|
(error "ETAF Data v2 committed outcome lacks a mutation result: %S"
|
|
raw))
|
|
;; A committed outcome is authoritative; pairing it with an error would
|
|
;; make the external state unknowable while falsely permitting a
|
|
;; read-only reconciliation. Treat that shape as malformed at the
|
|
;; boundary and let the caller conservatively classify it unknown.
|
|
(when (and (eq certainty 'committed)
|
|
(plist-get raw :error))
|
|
(error "ETAF Data v2 committed outcome cannot carry :error: %S"
|
|
raw))
|
|
(when (and error-condition
|
|
(not (etaf-data--condition-object-p error-condition)))
|
|
(error "ETAF Data v2 outcome :error is not a condition: %S" raw))
|
|
(when (and (eq certainty 'rolled-back)
|
|
(not (etaf-data--condition-object-p error-condition)))
|
|
(error "ETAF Data v2 rolled-back outcome lacks a condition: %S" raw))
|
|
(list :certainty certainty
|
|
:external-commit-certainty certainty
|
|
:result (if has-result result mutation-result)
|
|
:mutation-result (if has-mutation-result
|
|
mutation-result
|
|
result)
|
|
:reconciliation-token
|
|
(plist-get raw :reconciliation-token)
|
|
:error error-condition
|
|
:raw raw))))
|
|
|
|
(defun etaf-data--record-value (record key)
|
|
"Return RECORD value at KEY for plist, alist, or hash table records."
|
|
(cond
|
|
((hash-table-p record) (gethash key record))
|
|
((and (proper-list-p record)
|
|
(zerop (% (length record) 2))
|
|
(keywordp (car record)))
|
|
(plist-get record key))
|
|
((listp record) (alist-get key record))
|
|
(t nil)))
|
|
|
|
(defun etaf-data--record-matches-p (record query)
|
|
"Return whether RECORD matches memory source QUERY."
|
|
(cond
|
|
((null query) t)
|
|
((functionp query) (funcall query record))
|
|
((stringp query)
|
|
(string-match-p
|
|
(regexp-quote (downcase query))
|
|
(downcase (prin1-to-string record))))
|
|
((and (listp query) (keywordp (car query)))
|
|
(cl-loop for (key value) on query by #'cddr
|
|
always (equal (etaf-data--record-value record key) value)))
|
|
((listp query)
|
|
(cl-loop for (key . value) in query
|
|
always (equal (etaf-data--record-value record key) value)))
|
|
(t (equal record query))))
|
|
|
|
(defun etaf-data--slice (items page page-size)
|
|
"Return the PAGE and PAGE-SIZE window from ITEMS."
|
|
(let* ((safe-page (max 1 (or page 1)))
|
|
(safe-page-size (max 1 (or page-size 20)))
|
|
(start (* (1- safe-page) safe-page-size))
|
|
(end (min (length items) (+ start safe-page-size))))
|
|
(if (>= start (length items))
|
|
nil
|
|
(cl-subseq items start end))))
|
|
|
|
(defun etaf-data--memory-record-id (record id-key)
|
|
"Return RECORD identity using ID-KEY."
|
|
(if id-key
|
|
(etaf-data--record-value record id-key)
|
|
record))
|
|
|
|
(defun etaf-data--memory-replace (items id-key payload)
|
|
"Return ITEMS with the record matching PAYLOAD and ID-KEY replaced."
|
|
(let* ((target-id (etaf-data--memory-record-id payload id-key))
|
|
(matched-p nil)
|
|
(next
|
|
(mapcar
|
|
(lambda (record)
|
|
(if (equal (etaf-data--memory-record-id record id-key) target-id)
|
|
(progn
|
|
(setq matched-p t)
|
|
payload)
|
|
record))
|
|
items)))
|
|
(unless matched-p
|
|
(error "No memory source record for id %S" target-id))
|
|
next))
|
|
|
|
;;;###autoload
|
|
(cl-defun etaf-data-memory-source (items &key id-key name)
|
|
"Create an in-memory Data source over ITEMS.
|
|
|
|
ID-KEY identifies records for `replace', `update', and `delete' mutations,
|
|
and is exposed to Data Controllers as the source's stable item identity.
|
|
NAME optionally labels the source for diagnostics.
|
|
Queries may be nil, a predicate, a search string, a plist, an alist, or an
|
|
exact value. Supported mutations are `insert', `replace', `update', `delete',
|
|
and `reset'."
|
|
(let* ((records (etaf-ref (copy-sequence items)
|
|
:name (or name 'etaf-data-memory-source)))
|
|
(query-function
|
|
(lambda (query current)
|
|
(cl-remove-if-not
|
|
(lambda (record)
|
|
(etaf-data--record-matches-p record query))
|
|
current))))
|
|
(etaf-data-source
|
|
:name name
|
|
:provider 'memory
|
|
:item-key (and id-key
|
|
(lambda (record)
|
|
(etaf-data--memory-record-id record id-key)))
|
|
:load (lambda (query page page-size)
|
|
(let* ((all (etaf-value records))
|
|
(filtered (funcall query-function query all)))
|
|
(list :items (etaf-data--slice filtered page page-size)
|
|
:total (length filtered)
|
|
:page (max 1 (or page 1))
|
|
:page-size (max 1 (or page-size 20)))))
|
|
:mutate (lambda (operation payload)
|
|
(pcase operation
|
|
('insert
|
|
(setf (etaf-value records)
|
|
(append (etaf-value records) (list payload))))
|
|
((or 'replace 'update)
|
|
(setf (etaf-value records)
|
|
(etaf-data--memory-replace
|
|
(etaf-value records) id-key payload)))
|
|
('delete
|
|
(let ((target-id (if id-key
|
|
payload
|
|
(etaf-data--memory-record-id
|
|
payload id-key))))
|
|
(setf (etaf-value records)
|
|
(cl-remove-if
|
|
(lambda (record)
|
|
(equal (etaf-data--memory-record-id record id-key)
|
|
target-id))
|
|
(etaf-value records)))))
|
|
('reset
|
|
(setf (etaf-value records) (copy-sequence payload)))
|
|
(_
|
|
(error "Unsupported memory source mutation: %S"
|
|
operation)))
|
|
(etaf-value records)))))
|
|
|
|
(defun etaf-data--require-controller (controller)
|
|
"Signal unless CONTROLLER is a Data Controller."
|
|
(unless (etaf-data-controller-p controller)
|
|
(signal 'wrong-type-argument (list 'etaf-data-controller-p controller)))
|
|
(when (etaf-data--controller-stopped-p controller)
|
|
(signal 'etaf-data-stopped-error (list controller)))
|
|
controller)
|
|
|
|
(defun etaf-data--normalize-result (result)
|
|
"Return a normalized source RESULT plist."
|
|
(unless (and (listp result)
|
|
(or (null result) (keywordp (car result))))
|
|
(error "ETAF Data source load must return a plist: %S" result))
|
|
(unless (plist-member result :items)
|
|
(error "ETAF Data source load result lacks :items"))
|
|
result)
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-source-load-page
|
|
(source &optional query page page-size)
|
|
"Load and normalize one SOURCE page without creating a Controller.
|
|
QUERY is passed through unchanged. PAGE and PAGE-SIZE default to 1 and 20.
|
|
This public preparation boundary performs no reactive publication; callers may
|
|
use its result as `:initial-result' for `etaf-data-controller'."
|
|
(let ((page (max 1 (or page 1)))
|
|
(page-size (max 1 (or page-size 20))))
|
|
(etaf-data--normalize-result
|
|
(etaf-data--source-load source query page page-size))))
|
|
|
|
(defun etaf-data--item-identity (controller item)
|
|
"Return ITEM's selection identity in CONTROLLER."
|
|
(if-let* ((item-key (etaf-data--controller-item-key controller)))
|
|
(funcall item-key item)
|
|
item))
|
|
|
|
(defun etaf-data--ensure-selected-ref (controller identity)
|
|
"Return CONTROLLER's retained boolean selection ref for IDENTITY."
|
|
(let* ((refs (etaf-data--controller-selected-refs controller))
|
|
(selected-ref (gethash identity refs)))
|
|
(or selected-ref
|
|
(let ((created
|
|
(etaf-ref
|
|
(not (null
|
|
(member identity
|
|
(etaf-data--controller-selection-snapshot
|
|
controller))))
|
|
:name 'etaf-data-selected)))
|
|
(puthash identity created refs)
|
|
created))))
|
|
|
|
(defun etaf-data--prepare-selected-refs (controller items)
|
|
"Materialize CONTROLLER selection dependencies for ITEMS before render."
|
|
(dolist (identity (etaf-data--controller-selection-snapshot controller))
|
|
(etaf-data--ensure-selected-ref controller identity))
|
|
(dolist (item items)
|
|
(etaf-data--ensure-selected-ref
|
|
controller (etaf-data--item-identity controller item))))
|
|
|
|
(defun etaf-data--projection-entry (name ref new-value)
|
|
"Build one immutable-looking projection ENTRY for REF and NEW-VALUE."
|
|
(list :name name
|
|
:ref ref
|
|
:expected-version (etaf-ref-version ref)
|
|
:old-version (etaf-ref-version ref)
|
|
:old-value (etaf-ref-value ref)
|
|
:new-value new-value
|
|
;; These fields form a tiny write-ahead journal for the precommit
|
|
;; boundary. They let rollback restore only values actually written
|
|
;; by this candidate, without clobbering an intervening external write
|
|
;; that won a version race while preparation was failing.
|
|
:applied-p nil
|
|
:applied-version nil
|
|
:applied-value nil))
|
|
|
|
(defun etaf-data--projection-context-ids (sources)
|
|
"Return scheduler context IDs touched by SOURCES' current subscribers."
|
|
(let ((contexts (make-hash-table :test #'eql)))
|
|
(dolist (source sources)
|
|
(maphash
|
|
(lambda (subscriber _present)
|
|
(let ((context (etaf--subscriber-scheduler-context subscriber)))
|
|
(when (or (and (etaf-runtime-route-p subscriber)
|
|
(etaf-runtime-route-live-p subscriber))
|
|
(and (etaf-effect-p subscriber)
|
|
(etaf-effect-active-p subscriber)))
|
|
(puthash (etaf-scheduler-context-id context) t contexts))))
|
|
(etaf--source-subscribers source)))
|
|
(sort (hash-table-keys contexts) #'<)))
|
|
|
|
(defun etaf-data--make-projection-candidate
|
|
(controller request-id kind fields &optional certainty mutation-result token
|
|
context-filter)
|
|
"Prepare a Data projection CANDIDATE for FIELDS.
|
|
|
|
FIELDS is a list of (NAME REF NEW-VALUE) triples. No live ref is changed by
|
|
this function. CONTEXT-FILTER is used only to compute the retry scope; the
|
|
actual subscriber fan-out remains scheduler-owned."
|
|
(let* ((entries (mapcar (lambda (field)
|
|
(etaf-data--projection-entry
|
|
(nth 0 field) (nth 1 field) (nth 2 field)))
|
|
fields))
|
|
(changed (cl-remove-if
|
|
(lambda (entry)
|
|
(funcall (or (etaf-ref-test (plist-get entry :ref))
|
|
#'etaf--reactive-same-p)
|
|
(plist-get entry :old-value)
|
|
(plist-get entry :new-value)))
|
|
entries))
|
|
(sources (delete-dups (mapcar (lambda (entry)
|
|
(plist-get entry :ref))
|
|
changed)))
|
|
(projection-id (cl-incf etaf-data--projection-id-counter))
|
|
(context-ids (etaf-data--projection-context-ids sources)))
|
|
(when context-filter
|
|
(setq context-ids (cl-remove-if-not context-filter context-ids)))
|
|
(etaf-data--projection-candidate-create
|
|
:controller-id (etaf-data--controller-id controller)
|
|
:request-id request-id
|
|
:projection-id projection-id
|
|
:dispatch-epoch projection-id
|
|
:kind kind
|
|
:entries entries
|
|
:changed-sources sources
|
|
:certainty certainty
|
|
:mutation-result mutation-result
|
|
:reconciliation-token token
|
|
:context-ids context-ids
|
|
:state 'prepared)))
|
|
|
|
(defun etaf-data--projection-default-apply-field (entry)
|
|
"Install one prepared projection ENTRY without dispatching subscribers."
|
|
(let* ((ref (plist-get entry :ref))
|
|
(old (plist-get entry :old-value))
|
|
(new (plist-get entry :new-value)))
|
|
(unless (funcall (or (etaf-ref-test ref) #'etaf--reactive-same-p)
|
|
old new)
|
|
;; This is deliberately the no-dispatch install boundary. All entries
|
|
;; are installed before any source is dispatched, so observers can never
|
|
;; see a half-published Data projection.
|
|
(setf (etaf-ref-value ref) new
|
|
(etaf-ref-version ref) (1+ (plist-get entry :old-version))))))
|
|
|
|
(defun etaf-data--projection-restore (candidate)
|
|
"Restore CANDIDATE's own writes after a precommit failure.
|
|
|
|
Restoration is compare-and-set style: a ref is restored only when its current
|
|
version/value still match the write recorded by this candidate. A concurrent
|
|
writer that changed the ref after our write is left intact, which is essential
|
|
for expected-version conflicts and avoids rolling back somebody else's
|
|
successful publication."
|
|
(dolist (entry (etaf-data--projection-candidate-entries candidate))
|
|
(when (plist-get entry :applied-p)
|
|
(let* ((ref (plist-get entry :ref))
|
|
(current-value (etaf-ref-value ref))
|
|
(current-version (etaf-ref-version ref))
|
|
(same-p (or (etaf-ref-test ref)
|
|
#'etaf--reactive-same-p)))
|
|
(when (and (= current-version (plist-get entry :applied-version))
|
|
(funcall same-p current-value
|
|
(plist-get entry :applied-value)))
|
|
(setf (etaf-ref-value ref) (plist-get entry :old-value)
|
|
(etaf-ref-version ref) (plist-get entry :old-version))))))
|
|
candidate)
|
|
|
|
(defun etaf-data--projection-context-filter (context-ids)
|
|
"Return a scheduler context predicate for CONTEXT-IDS.
|
|
|
|
Nil means all contexts (the ordinary publication path); the private
|
|
`etaf-data--no-contexts' marker means none. This distinction is important for
|
|
a retry whose failed-context set is already empty."
|
|
(cond
|
|
((null context-ids) nil)
|
|
((eq context-ids etaf-data--no-contexts)
|
|
(lambda (_context) nil))
|
|
(t
|
|
(lambda (context)
|
|
(memq (etaf-scheduler-context-id context) context-ids)))))
|
|
|
|
(defun etaf-data--projection-dispatch (candidate &optional context-ids)
|
|
"Dispatch changed sources in CANDIDATE and return summary/condition data."
|
|
(let (summary condition
|
|
(deferred-p (etaf-scheduler-projection-active-p)))
|
|
(if (or (null (etaf-data--projection-candidate-changed-sources candidate))
|
|
(eq context-ids etaf-data--no-contexts))
|
|
(list :summary nil :condition nil)
|
|
(let ((captured
|
|
(etaf-data--transparent-condition-boundary
|
|
(lambda ()
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-scheduler-call-with-projection
|
|
(lambda ()
|
|
(etaf-scheduler-on-projection-complete
|
|
(lambda (completed-summary)
|
|
(setq summary completed-summary)))
|
|
(let ((filter
|
|
(etaf-data--projection-context-filter context-ids)))
|
|
(dolist
|
|
(source
|
|
(etaf-data--projection-candidate-changed-sources
|
|
candidate))
|
|
(etaf--dispatch-source source filter)))))))))))
|
|
(setq condition (plist-get captured :condition)))
|
|
(list :summary summary :condition condition :deferred-p deferred-p))))
|
|
|
|
(defun etaf-data--projection-failed-context-ids
|
|
(candidate summary condition &optional attempted-context-ids)
|
|
"Return context IDs that failed dispatch for CANDIDATE.
|
|
|
|
ATTEMPTED-CONTEXT-IDS is used by partial retries so a condition in one retry
|
|
cannot accidentally mark already successful contexts as failed again."
|
|
(let* ((attempted (or attempted-context-ids
|
|
(etaf-data--projection-candidate-context-ids candidate)))
|
|
failed)
|
|
(when (and summary (plist-get summary :contexts))
|
|
(dolist (context (plist-get summary :contexts))
|
|
(let ((context-id (plist-get context :context-id)))
|
|
(when (and (memq context-id attempted)
|
|
(or (> (or (plist-get context :faults) 0) 0)
|
|
;; A stale route was intentionally skipped rather
|
|
;; than completed. Keep that context pending so a
|
|
;; later live route in the same context can be
|
|
;; reconciled, while retry target selection still
|
|
;; filters out the detached route itself.
|
|
(> (or (plist-get context :stale-route-drops) 0)
|
|
0)))
|
|
(push context-id failed)))))
|
|
(when (and condition (null summary))
|
|
(setq failed (copy-sequence attempted)))
|
|
(delete-dups (nreverse failed))))
|
|
|
|
(defun etaf-data--projection-mark-token
|
|
(candidate summary condition failed-context-ids &optional attempted merge-p)
|
|
"Update CANDIDATE's token and context completion metadata."
|
|
(let* ((contexts (etaf-data--projection-candidate-context-ids candidate))
|
|
(attempted (or attempted contexts))
|
|
(token (etaf-data--projection-candidate-reconciliation-token candidate))
|
|
(old-completed (and token (plist-get token :completed-context-ids)))
|
|
(old-failed (and token (plist-get token :failed-context-ids)))
|
|
(completed-now (cl-set-difference attempted failed-context-ids))
|
|
(completed (if merge-p
|
|
(cl-union old-completed completed-now)
|
|
(cl-set-difference contexts failed-context-ids)))
|
|
(failed (if merge-p
|
|
(cl-union
|
|
(cl-set-difference old-failed completed-now)
|
|
failed-context-ids)
|
|
failed-context-ids)))
|
|
(setf (etaf-data--projection-candidate-completed-context-ids candidate)
|
|
completed
|
|
(etaf-data--projection-candidate-failed-context-ids candidate)
|
|
failed)
|
|
(when token
|
|
(etaf-data--token-put token :projection-token
|
|
(etaf-data--projection-candidate-dispatch-epoch
|
|
candidate))
|
|
(etaf-data--token-put token :dispatch-epoch
|
|
(etaf-data--projection-candidate-dispatch-epoch
|
|
candidate))
|
|
(etaf-data--token-put token :completed-context-ids completed)
|
|
(etaf-data--token-put token :failed-context-ids failed)
|
|
(etaf-data--token-put token :last-summary summary)
|
|
(etaf-data--token-put token :last-condition condition)
|
|
(etaf-data--token-put
|
|
token :state
|
|
(cond
|
|
((eq (etaf-data--projection-candidate-certainty candidate)
|
|
'external-unknown)
|
|
'external-unknown)
|
|
((eq (etaf-data--projection-candidate-certainty candidate)
|
|
'rolled-back)
|
|
'rolled-back)
|
|
(condition 'render-pending)
|
|
(failed 'projection-pending)
|
|
((eq (etaf-data--projection-candidate-kind candidate) 'load-error)
|
|
(if (eq (etaf-data--projection-candidate-certainty candidate)
|
|
'committed)
|
|
'projection-pending
|
|
'projected))
|
|
(t 'projected))))
|
|
candidate))
|
|
|
|
(defun etaf-data--commit-projection
|
|
(controller candidate &optional context-ids suppress-test-hooks)
|
|
"Atomically install CANDIDATE and dispatch it once per target context.
|
|
|
|
The return value is a plist containing `:candidate', `:summary', and optional
|
|
`:condition'. A preparation/field failure signals after restoring every ref;
|
|
a dispatch failure leaves committed refs in place and is returned for the
|
|
caller to decorate with a cause-compatible projection trailer.
|
|
|
|
When SUPPRESS-TEST-HOOKS is non-nil, the loading marker uses the production
|
|
field installer even when the test-only fault hooks are bound. This keeps a
|
|
fault injected into the data-bearing success/error candidate from preventing
|
|
the source boundary from being observed; loading remains an observable
|
|
candidate without becoming a second fault-injection target."
|
|
;; Candidates are one-shot transactions. A committed candidate must never
|
|
;; re-enter the precommit path: doing so would compare its old expected
|
|
;; versions against the now-advanced refs, then the rollback journal could
|
|
;; incorrectly restore a publication that already escaped to observers.
|
|
(unless (eq (etaf-data--projection-candidate-state candidate) 'prepared)
|
|
(signal 'etaf-data-projection-conflict
|
|
(list :projection-id
|
|
(etaf-data--projection-candidate-projection-id candidate)
|
|
:state
|
|
(etaf-data--projection-candidate-state candidate))))
|
|
(setf (etaf-data--controller-projection-candidate controller) candidate)
|
|
(let* ((prepared
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
;; A field-apply hook is test-only, but the commit boundary itself
|
|
;; remains quit-safe and validates every captured version first.
|
|
(let ((inhibit-quit t))
|
|
(when (and (not suppress-test-hooks)
|
|
(functionp etaf-data--projection-before-commit-hook))
|
|
(funcall etaf-data--projection-before-commit-hook candidate))
|
|
(unless (= (etaf-data--projection-candidate-request-id candidate)
|
|
(etaf-data--controller-request-id controller))
|
|
(signal 'etaf-data-projection-conflict
|
|
(list :request-id
|
|
(etaf-data--projection-candidate-request-id
|
|
candidate)
|
|
:current-request-id
|
|
(etaf-data--controller-request-id controller))))
|
|
;; Validate every expected version before installing any field.
|
|
(dolist (entry
|
|
(etaf-data--projection-candidate-entries candidate))
|
|
(unless (= (etaf-ref-version (plist-get entry :ref))
|
|
(plist-get entry :expected-version))
|
|
(signal 'etaf-data-projection-conflict
|
|
(list :field (plist-get entry :name)
|
|
:expected-version
|
|
(plist-get entry :expected-version)
|
|
:actual-version
|
|
(etaf-ref-version (plist-get entry :ref))))))
|
|
;; Install the complete candidate exactly once, after all
|
|
;; expected versions have passed validation.
|
|
(let ((apply-field
|
|
(if suppress-test-hooks
|
|
#'etaf-data--projection-default-apply-field
|
|
(or etaf-data--projection-field-apply-function
|
|
#'etaf-data--projection-default-apply-field))))
|
|
(dolist (entry
|
|
(etaf-data--projection-candidate-entries candidate))
|
|
(let ((before-version (etaf-ref-version
|
|
(plist-get entry :ref)))
|
|
(before-value (etaf-ref-value (plist-get entry :ref))))
|
|
(unwind-protect
|
|
(funcall apply-field entry)
|
|
;; Record a write even when a faulting test adapter
|
|
;; signals after changing the ref. The restore path
|
|
;; will then perform a CAS against this exact value and
|
|
;; version, preserving any later competing writer.
|
|
(let* ((ref (plist-get entry :ref))
|
|
(after-version (etaf-ref-version ref))
|
|
(after-value (etaf-ref-value ref))
|
|
(same-p (or (etaf-ref-test ref)
|
|
#'etaf--reactive-same-p)))
|
|
(when (or (/= before-version after-version)
|
|
(not (funcall same-p before-value
|
|
after-value)))
|
|
(setf (plist-get entry :applied-p) t
|
|
(plist-get entry :applied-version)
|
|
after-version
|
|
(plist-get entry :applied-value)
|
|
after-value)))))))
|
|
t))))
|
|
(precommit-condition (plist-get prepared :condition)))
|
|
(when precommit-condition
|
|
(etaf-data--projection-restore candidate)
|
|
(setf (etaf-data--projection-candidate-state candidate) 'aborted)
|
|
(etaf-data--signal-condition precommit-condition))
|
|
(setf (etaf-data--projection-candidate-state candidate) 'committed)
|
|
(push candidate (etaf-data--controller-projection-history controller))
|
|
(when (> (length (etaf-data--controller-projection-history controller))
|
|
etaf-data--projection-history-limit)
|
|
(setf (etaf-data--controller-projection-history controller)
|
|
(cl-subseq (etaf-data--controller-projection-history controller)
|
|
0 etaf-data--projection-history-limit)))
|
|
(let* ((dispatch (etaf-data--projection-dispatch candidate context-ids))
|
|
(summary (plist-get dispatch :summary))
|
|
(condition (plist-get dispatch :condition))
|
|
(failed (etaf-data--projection-failed-context-ids
|
|
candidate summary condition
|
|
(and (not (eq context-ids etaf-data--no-contexts))
|
|
(if context-ids
|
|
context-ids
|
|
(etaf-data--projection-candidate-context-ids
|
|
candidate))))))
|
|
(if (plist-get dispatch :deferred-p)
|
|
;; Nested Data publication joins the caller's scheduler projection.
|
|
;; Its completion summary (including per-context faults) is only
|
|
;; available after the outer drain, so finalize the candidate from a
|
|
;; completion observer rather than claiming every context now.
|
|
(etaf-scheduler-on-projection-complete
|
|
(lambda (completed-summary)
|
|
(let* ((completed-condition
|
|
(plist-get completed-summary :condition))
|
|
(completed-failed
|
|
(etaf-data--projection-failed-context-ids
|
|
candidate completed-summary completed-condition
|
|
(and (not (eq context-ids etaf-data--no-contexts))
|
|
(if context-ids
|
|
context-ids
|
|
(etaf-data--projection-candidate-context-ids
|
|
candidate))))))
|
|
(etaf-data--projection-mark-token
|
|
candidate completed-summary completed-condition
|
|
completed-failed nil nil))))
|
|
(etaf-data--projection-mark-token candidate summary condition failed
|
|
nil nil))
|
|
(list :candidate candidate :summary summary :condition condition))))
|
|
|
|
(defun etaf-data--projection-condition-trailer (candidate)
|
|
"Return the fixed v1 trailer for Data projection CANDIDATE."
|
|
(let* ((token (etaf-data--projection-candidate-reconciliation-token candidate))
|
|
(projection-id
|
|
(etaf-data--projection-candidate-dispatch-epoch candidate))
|
|
(certainty
|
|
(or (etaf-data--projection-candidate-certainty candidate)
|
|
'committed))
|
|
(result
|
|
(etaf-data--projection-candidate-mutation-result candidate))
|
|
(operation-id (or (and token (plist-get token :operation-id)) 0))
|
|
(outcome-id (or (and token (plist-get token :id)) projection-id)))
|
|
(list :etaf-condition-trailer/v1
|
|
(list :kind 'projection
|
|
:committed-p t
|
|
:external-commit-certainty certainty
|
|
:reconciliation-token token
|
|
:projection-token projection-id
|
|
:result result
|
|
:operation-id operation-id
|
|
:outcome-id outcome-id
|
|
:generation-id 0
|
|
:revision 0
|
|
:diagnostic-journal-id (max 1 projection-id)))))
|
|
|
|
(defun etaf-data--decorate-projection-condition (condition candidate)
|
|
"Append CANDIDATE's trailer to CONDITION while preserving its prefix."
|
|
(if (or (not (consp condition))
|
|
;; Do not append a second Data trailer when a retry or nested
|
|
;; boundary has already decorated this condition. A legacy
|
|
;; postcommit trailer is a different kind and must remain in the
|
|
;; prefix while Data adds its projection metadata at the end.
|
|
(etaf-data-condition-projection-info condition))
|
|
condition
|
|
(append (copy-tree condition)
|
|
(list (etaf-data--projection-condition-trailer candidate)))))
|
|
|
|
(defun etaf-data--projection-condition-prefix (condition)
|
|
"Return CONDITION without a terminal Data projection trailer.
|
|
|
|
Projection conditions captured from `etaf-data--apply-error' are already
|
|
decorated. Storing that decorated condition inside the token that the trailer
|
|
itself references would create a cyclic diagnostic object; retain only its
|
|
cause-compatible prefix in token metadata instead."
|
|
(copy-tree
|
|
(if (etaf-data-condition-projection-info condition)
|
|
(butlast condition)
|
|
condition)))
|
|
|
|
(defun etaf-data--ensure-projection-token (controller candidate)
|
|
"Ensure CANDIDATE has a Data token for a projection diagnostic.
|
|
|
|
Ordinary successful loads do not expose a reconciliation token. If their
|
|
render/projection path fails, however, the fixed trailer still needs an opaque
|
|
token so callers can distinguish and inspect that failure without replaying a
|
|
source mutation."
|
|
(or (etaf-data--projection-candidate-reconciliation-token candidate)
|
|
;; A plain read has no external mutation certainty. Its original
|
|
;; condition remains the public diagnostic; only mutation/reconciliation
|
|
;; projections receive the certainty trailer.
|
|
(when (etaf-data--projection-candidate-certainty candidate)
|
|
(let ((token (etaf-data--make-reconciliation-token
|
|
controller 0 'committed nil)))
|
|
(setf (etaf-data--projection-candidate-reconciliation-token candidate)
|
|
token
|
|
(etaf-data--controller-reconciliation-token controller) token)
|
|
(etaf-data--token-put token :state 'render-pending)
|
|
token))))
|
|
|
|
(defun etaf-data--load-fields (controller normalized)
|
|
"Return the stable controller fields for normalized load NORMALIZED."
|
|
(append
|
|
(list (list 'items (etaf-data--controller-items controller)
|
|
(plist-get normalized :items))
|
|
(list 'total (etaf-data--controller-total controller)
|
|
(or (plist-get normalized :total)
|
|
(length (plist-get normalized :items)))))
|
|
(when (plist-member normalized :page)
|
|
(list (list 'page (etaf-data--controller-page controller)
|
|
(plist-get normalized :page))))
|
|
(when (plist-member normalized :page-size)
|
|
(list (list 'page-size (etaf-data--controller-page-size controller)
|
|
(plist-get normalized :page-size))))
|
|
(list (list 'error (etaf-data--controller-error controller) nil)
|
|
(list 'status (etaf-data--controller-status controller) 'success))))
|
|
|
|
(defun etaf-data--publish-projection-failure (controller condition)
|
|
"Publish a safe error state after a Data projection commit aborts.
|
|
|
|
Loading is intentionally visible before a source call. If the later
|
|
multi-field candidate cannot commit, leaving that marker in place would make a
|
|
controller report `loading' forever. This fallback bypasses the fault-injected
|
|
candidate installer, atomically writes the observable error/status pair, and
|
|
still lets scheduler containment report any render fault separately."
|
|
(etaf-reactive-call-with-batch
|
|
(lambda ()
|
|
(setf (etaf-value (etaf-data--controller-error controller)) condition
|
|
(etaf-value (etaf-data--controller-status controller)) 'error))))
|
|
|
|
(defun etaf-data--apply-load-loading (controller request-id)
|
|
"Publish the loading marker as a first-class projection candidate.
|
|
|
|
The marker is committed before the source callback runs, so a source can
|
|
observe `loading' through the ordinary public status ref. Test-only field and
|
|
precommit fault hooks are suppressed for this marker; data-bearing success and
|
|
error candidates remain the fault-injection boundary for atomicity tests."
|
|
(when (= request-id (etaf-data--controller-request-id controller))
|
|
(let* ((candidate
|
|
(etaf-data--make-projection-candidate
|
|
controller request-id 'loading
|
|
(list (list 'error (etaf-data--controller-error controller) nil)
|
|
(list 'status (etaf-data--controller-status controller)
|
|
'loading))))
|
|
(publication
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-scheduler-call-with-projection
|
|
(lambda ()
|
|
(etaf-data--commit-projection
|
|
controller candidate nil t))))))
|
|
(condition (plist-get publication :condition)))
|
|
;; A loading projection has no external certainty and therefore no
|
|
;; reconciliation token. Surface a scheduler/precommit fault using its
|
|
;; normal condition contract rather than silently proceeding. The
|
|
;; loading marker itself must not strand a controller in `loading': use
|
|
;; the safe terminal error publication when its dispatch fails.
|
|
(when condition
|
|
(ignore
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--publish-projection-failure controller condition))))
|
|
(etaf-data--signal-condition condition))
|
|
publication)))
|
|
|
|
(defun etaf-data--apply-load-success
|
|
(controller request-id result &optional reconciliation-token outcome
|
|
context-ids)
|
|
"Publish successful RESULT for CONTROLLER when REQUEST-ID is current.
|
|
|
|
RECONCILIATION-TOKEN and OUTCOME identify an external mutation, when present.
|
|
CONTEXT-IDS is an optional retry allow-list; nil means every live context."
|
|
(when (= request-id (etaf-data--controller-request-id controller))
|
|
(let* ((normalized (etaf-data--normalize-result result))
|
|
(certainty (and outcome (plist-get outcome :certainty)))
|
|
(mutation-result (and outcome
|
|
(or (plist-get outcome :mutation-result)
|
|
(plist-get outcome :result))))
|
|
(token (or reconciliation-token
|
|
(and outcome
|
|
(etaf-data--make-reconciliation-token
|
|
controller
|
|
(or (plist-get outcome :operation-id) 0)
|
|
certainty mutation-result
|
|
(plist-get outcome :reconciliation-token)))))
|
|
(auto-load-p (etaf-data--controller-auto-load-p controller))
|
|
candidate committed capture)
|
|
(when token
|
|
(setf (etaf-data--controller-reconciliation-token controller) token))
|
|
(setf (etaf-data--controller-auto-load-p controller) nil)
|
|
;; Keep the auto-load guard through the *outer* scheduler projection. A
|
|
;; normalized page write can enqueue the auto-load effect; restoring the
|
|
;; flag before that projection drains would issue a duplicate load.
|
|
(setq capture
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
;; Materialize keyed selection dependencies inside the same
|
|
;; preparation capture as candidate construction. User-owned
|
|
;; item keys may signal; such a fault must terminate the
|
|
;; loading marker rather than leave the controller stuck there.
|
|
(etaf-data--prepare-selected-refs
|
|
controller (plist-get normalized :items))
|
|
(etaf-scheduler-call-with-projection
|
|
(lambda ()
|
|
(etaf-scheduler-defer-finalizer
|
|
(lambda ()
|
|
(setf (etaf-data--controller-auto-load-p controller)
|
|
auto-load-p)))
|
|
(setq candidate
|
|
(etaf-data--make-projection-candidate
|
|
controller request-id 'success
|
|
(etaf-data--load-fields controller normalized)
|
|
certainty mutation-result token))
|
|
(setq committed
|
|
(etaf-data--commit-projection
|
|
controller candidate context-ids)))))))
|
|
(let ((caught (plist-get capture :condition)))
|
|
(unless candidate
|
|
;; Materialization can fail before a candidate exists (for example,
|
|
;; an item-key callback can signal). Publish a terminal error
|
|
;; directly so the loading marker cannot remain stuck, then preserve
|
|
;; the projection condition for the caller.
|
|
(setf (etaf-data--controller-auto-load-p controller) auto-load-p)
|
|
(ignore
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--apply-error controller request-id caught))))
|
|
(etaf-data--signal-condition caught))
|
|
(when caught
|
|
(when (or token
|
|
(and candidate
|
|
(eq (car caught) 'etaf-data-projection-conflict)))
|
|
(let ((diagnostic-token
|
|
(etaf-data--ensure-projection-token controller candidate)))
|
|
(when diagnostic-token
|
|
;; A candidate that never committed is a precommit conflict;
|
|
;; a committed candidate whose outer scheduler drain signalled
|
|
;; is a render/projection failure. Do not collapse the latter
|
|
;; into a misleading precommit state.
|
|
(etaf-data--token-put
|
|
diagnostic-token :state
|
|
(if (eq (and candidate
|
|
(etaf-data--projection-candidate-state candidate))
|
|
'aborted)
|
|
'projection-pending
|
|
'render-pending))))))
|
|
(when (and candidate
|
|
(eq (etaf-data--projection-candidate-state candidate)
|
|
'aborted)
|
|
(= (etaf-data--projection-candidate-request-id candidate)
|
|
(etaf-data--controller-request-id controller)))
|
|
;; The loading marker was committed in its own pre-source turn;
|
|
;; replace it with an observable error when the candidate itself
|
|
;; aborts before any Data field is published.
|
|
(ignore
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--publish-projection-failure controller caught)))))
|
|
(let ((decorated
|
|
(if (and candidate
|
|
(etaf-data--projection-candidate-reconciliation-token
|
|
candidate))
|
|
(etaf-data--decorate-projection-condition caught candidate)
|
|
caught)))
|
|
(etaf-data--signal-condition decorated)))
|
|
(when-let* ((condition (and committed
|
|
(plist-get committed :condition))))
|
|
(unless (etaf-data--projection-candidate-reconciliation-token
|
|
candidate)
|
|
(etaf-data--ensure-projection-token controller candidate))
|
|
;; Plain v1 loads have no external mutation certainty or
|
|
;; reconciliation token. Preserve their historical raw condition;
|
|
;; only mutation/reconciliation projections receive the fixed
|
|
;; token-bearing trailer.
|
|
(etaf-data--signal-condition
|
|
(if (etaf-data--projection-candidate-reconciliation-token candidate)
|
|
(etaf-data--decorate-projection-condition condition candidate)
|
|
condition)))
|
|
result)))
|
|
|
|
(defun etaf-data--apply-error
|
|
(controller request-id error-data &optional reconciliation-token outcome)
|
|
"Atomically publish ERROR-DATA and status for current REQUEST-ID.
|
|
The old items/page values remain untouched. Return the projection result."
|
|
(when (= request-id (etaf-data--controller-request-id controller))
|
|
(let* ((certainty (and outcome (plist-get outcome :certainty)))
|
|
(mutation-result (and outcome
|
|
(or (plist-get outcome :mutation-result)
|
|
(plist-get outcome :result))))
|
|
(token (or reconciliation-token
|
|
(and outcome
|
|
(etaf-data--make-reconciliation-token
|
|
controller
|
|
(or (plist-get outcome :operation-id) 0)
|
|
certainty mutation-result
|
|
(plist-get outcome :reconciliation-token)))))
|
|
(candidate
|
|
(etaf-data--make-projection-candidate
|
|
controller request-id 'load-error
|
|
(list (list 'error (etaf-data--controller-error controller)
|
|
error-data)
|
|
(list 'status (etaf-data--controller-status controller)
|
|
'error))
|
|
certainty mutation-result token))
|
|
(publication
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-scheduler-call-with-projection
|
|
(lambda ()
|
|
(etaf-data--commit-projection controller candidate
|
|
nil))))))
|
|
(committed (plist-get publication :value))
|
|
(projection-condition (plist-get publication :condition)))
|
|
;; Keep the reconciliation token visible even when the candidate aborts
|
|
;; before the scheduler call returns. This is needed for a committed
|
|
;; mutation whose read-side error projection must be retried read-only.
|
|
(when token
|
|
(setf (etaf-data--controller-reconciliation-token controller) token))
|
|
(when (and projection-condition
|
|
(eq (etaf-data--projection-candidate-state candidate)
|
|
'aborted))
|
|
;; `loading' was published before the source boundary ran. If the
|
|
;; error/status candidate itself faults during precommit, install a
|
|
;; safe terminal error directly so the controller cannot remain stuck
|
|
;; in `loading'. The original ERROR-DATA remains the public source
|
|
;; condition; PROJECTION-CONDITION is re-signaled below for callers
|
|
;; that observe the projection boundary directly.
|
|
(ignore
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--publish-projection-failure controller error-data))))
|
|
(when token
|
|
(etaf-data--token-put
|
|
token :state
|
|
(pcase certainty
|
|
('external-unknown 'external-unknown)
|
|
('rolled-back 'rolled-back)
|
|
(_ 'projection-pending)))))
|
|
(when-let* ((condition (or (and committed
|
|
(plist-get committed :condition))
|
|
projection-condition)))
|
|
(unless (etaf-data--projection-candidate-reconciliation-token
|
|
candidate)
|
|
(etaf-data--ensure-projection-token controller candidate))
|
|
(etaf-data--signal-condition
|
|
(etaf-data--decorate-projection-condition condition candidate)))
|
|
committed)))
|
|
|
|
(defun etaf-data--decorate-reconciliation-condition
|
|
(controller condition outcome token)
|
|
"Decorate a reconciliation load CONDITION when its facts committed.
|
|
|
|
Plain v1 loads retain their historical raw condition. Once a mutation outcome
|
|
is known to be committed, however, a failed read is part of the
|
|
committed-but-unprojected reconciliation diagnostic and carries the same
|
|
cause-compatible projection trailer as a render fault."
|
|
(let ((candidate (etaf-data--controller-projection-candidate controller)))
|
|
(if (and condition outcome token
|
|
(eq (plist-get outcome :certainty) 'committed)
|
|
candidate
|
|
(eq (etaf-data--projection-candidate-state candidate) 'committed)
|
|
(eq (etaf-data--projection-candidate-reconciliation-token
|
|
candidate)
|
|
token))
|
|
(etaf-data--decorate-projection-condition condition candidate)
|
|
condition)))
|
|
|
|
;;;###autoload
|
|
(cl-defun etaf-data-controller
|
|
(source &key query (page 1) (page-size 20) selection auto-load name
|
|
item-key owner-scope initial-result)
|
|
"Create a reactive Data Controller for SOURCE.
|
|
|
|
QUERY, PAGE, PAGE-SIZE, result ITEMS, TOTAL, STATUS, ERROR, and SELECTION are
|
|
stored in refs. When AUTO-LOAD is non-nil, the controller loads immediately
|
|
and reloads after query or pagination refs change. NAME optionally labels the
|
|
controller for diagnostics. ITEM-KEY identifies selection and selected-item
|
|
state; it defaults to the source's `:item-key' capability when available.
|
|
When OWNER-SCOPE is supplied, or when a current ETAF Scope exists, the
|
|
controller's own child Scope is disposed with that owner; otherwise it keeps
|
|
the detached Scope behavior. INITIAL-RESULT may be a normalized source result
|
|
for QUERY/PAGE/PAGE-SIZE; it seeds a successful Controller without another
|
|
load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive."
|
|
(unless (etaf-data-source-p source)
|
|
(signal 'wrong-type-argument (list 'etaf-data-source-p source)))
|
|
(setq item-key (or item-key (plist-get source :item-key)))
|
|
(unless (or (null item-key) (functionp item-key))
|
|
(signal 'wrong-type-argument (list 'functionp item-key)))
|
|
(when (and initial-result auto-load)
|
|
(error "ETAF Data :initial-result and :auto-load are mutually exclusive"))
|
|
(let* ((initial-result (and initial-result
|
|
(etaf-data--normalize-result initial-result)))
|
|
(initial-items (and initial-result
|
|
(plist-get initial-result :items)))
|
|
(initial-page (if (and initial-result
|
|
(plist-member initial-result :page))
|
|
(plist-get initial-result :page)
|
|
page))
|
|
(initial-page-size
|
|
(if (and initial-result
|
|
(plist-member initial-result :page-size))
|
|
(plist-get initial-result :page-size)
|
|
page-size))
|
|
(owner-scope (or owner-scope (etaf-current-effect-scope)))
|
|
(scope (if owner-scope
|
|
(etaf-scope-run
|
|
owner-scope
|
|
(lambda ()
|
|
(etaf-effect-scope :name (or name 'etaf-data))))
|
|
(etaf-effect-scope :detached t :name (or name 'etaf-data))))
|
|
(controller
|
|
(etaf-data--controller-create
|
|
:source source
|
|
:scope scope
|
|
:query (etaf-ref query :name 'etaf-data-query)
|
|
:page (etaf-ref initial-page :name 'etaf-data-page)
|
|
:page-size (etaf-ref initial-page-size :name 'etaf-data-page-size)
|
|
:items (etaf-ref initial-items :name 'etaf-data-items)
|
|
:total (etaf-ref (if initial-result
|
|
(or (plist-get initial-result :total)
|
|
(length initial-items))
|
|
0)
|
|
:name 'etaf-data-total)
|
|
:status (etaf-ref (if initial-result 'success 'idle)
|
|
:name 'etaf-data-status)
|
|
:error (etaf-ref nil :name 'etaf-data-error)
|
|
:selection (etaf-ref (copy-sequence selection)
|
|
:name 'etaf-data-selection)
|
|
:selection-snapshot (copy-sequence selection)
|
|
:selected-refs (make-hash-table :test #'equal)
|
|
:id (cl-incf etaf-data--controller-id-counter)
|
|
:mutation-outcome nil
|
|
:reconciliation-token nil
|
|
:projection-candidate nil
|
|
:projection-history nil
|
|
:request-id 0
|
|
:auto-load-p auto-load
|
|
:item-key item-key)))
|
|
(etaf-data--prepare-selected-refs controller initial-items)
|
|
(etaf-scope-run
|
|
scope
|
|
(lambda ()
|
|
(etaf-watch
|
|
(etaf-data--controller-selection controller)
|
|
(lambda (new-selection old-selection)
|
|
(setf (etaf-data--controller-selection-snapshot controller)
|
|
new-selection)
|
|
(dolist (identity new-selection)
|
|
(etaf-data--ensure-selected-ref controller identity))
|
|
(let ((selected-refs
|
|
(etaf-data--controller-selected-refs controller)))
|
|
(unless (zerop (hash-table-count selected-refs))
|
|
(let ((old-set (make-hash-table :test #'equal))
|
|
(new-set (make-hash-table :test #'equal)))
|
|
(dolist (identity old-selection)
|
|
(puthash identity t old-set))
|
|
(dolist (identity new-selection)
|
|
(puthash identity t new-set))
|
|
(maphash
|
|
(lambda (identity _present)
|
|
(unless (gethash identity new-set)
|
|
(when-let* ((selected-ref
|
|
(gethash identity selected-refs)))
|
|
(setf (etaf-value selected-ref) nil))))
|
|
old-set)
|
|
(maphash
|
|
(lambda (identity _present)
|
|
(unless (gethash identity old-set)
|
|
(when-let* ((selected-ref
|
|
(gethash identity selected-refs)))
|
|
(setf (etaf-value selected-ref) t))))
|
|
new-set)))))
|
|
:name 'etaf-data-selection-index)
|
|
(let ((effect
|
|
(etaf-reactive-effect-create
|
|
(lambda ()
|
|
(etaf-value (etaf-data--controller-query controller))
|
|
(etaf-value (etaf-data--controller-page controller))
|
|
(etaf-value (etaf-data--controller-page-size controller)))
|
|
:name 'etaf-data-auto-load
|
|
:scheduler
|
|
(lambda (_effect)
|
|
(when (and (etaf-data--controller-auto-load-p controller)
|
|
(not (etaf-data--controller-stopped-p
|
|
controller)))
|
|
(etaf-data-load controller))))))
|
|
(etaf-reactive-effect-run effect))
|
|
(etaf-on-scope-dispose
|
|
(lambda ()
|
|
(clrhash (etaf-data--controller-selected-refs controller))
|
|
(when-let* ((dispose (etaf-data--source-function
|
|
source :dispose nil)))
|
|
(funcall dispose))))))
|
|
(when auto-load
|
|
(etaf-data-load controller))
|
|
controller))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data--load-request
|
|
(controller &optional outcome reconciliation-token)
|
|
"Run one source load and return its result/condition envelope.
|
|
|
|
OUTCOME and RECONCILIATION-TOKEN identify a previously committed mutation;
|
|
the load itself is always a fresh request and never replays that mutation."
|
|
(let ((request-id (1+ (etaf-data--controller-request-id controller))))
|
|
(setf (etaf-data--controller-request-id controller) request-id)
|
|
(etaf-data--apply-load-loading controller request-id)
|
|
(let* ((source-call
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--source-load
|
|
(etaf-data--controller-source controller)
|
|
(etaf-value (etaf-data--controller-query controller))
|
|
(etaf-value (etaf-data--controller-page controller))
|
|
(etaf-value (etaf-data--controller-page-size controller))))))
|
|
(source-condition (plist-get source-call :condition))
|
|
(result (plist-get source-call :value)))
|
|
(if source-condition
|
|
(let* ((publication
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--apply-error
|
|
controller request-id source-condition
|
|
reconciliation-token outcome))))
|
|
(projection-condition (plist-get publication :condition)))
|
|
;; A source failure is the primary public condition. If publishing
|
|
;; its status/error also fails, the projection condition remains
|
|
;; discoverable through the token but does not mask the source
|
|
;; callback's compatibility contract.
|
|
(list :request-id request-id :result nil
|
|
:condition
|
|
(etaf-data--decorate-reconciliation-condition
|
|
controller source-condition outcome reconciliation-token)
|
|
:projection-condition projection-condition
|
|
:source-condition source-condition))
|
|
(let* ((normalization
|
|
(etaf-data--capture-condition
|
|
(lambda () (etaf-data--normalize-result result))))
|
|
(normalization-condition (plist-get normalization :condition))
|
|
(publication
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(if normalization-condition
|
|
;; A malformed source result is a load error, not a
|
|
;; projection/render fault. Publish status/error
|
|
;; atomically so the controller cannot remain stuck in
|
|
;; `loading' after the source boundary returned.
|
|
(etaf-data--apply-error
|
|
controller request-id normalization-condition
|
|
reconciliation-token outcome)
|
|
(etaf-data--apply-load-success
|
|
controller request-id result
|
|
reconciliation-token outcome)))))
|
|
(projection-condition (plist-get publication :condition)))
|
|
(list :request-id request-id
|
|
:result (unless normalization-condition result)
|
|
:condition
|
|
(or (and normalization-condition
|
|
(etaf-data--decorate-reconciliation-condition
|
|
controller normalization-condition outcome
|
|
reconciliation-token))
|
|
projection-condition)
|
|
:projection-condition
|
|
(and normalization-condition projection-condition)
|
|
:source-condition normalization-condition))))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-load (controller)
|
|
"Load CONTROLLER from its source and publish loading, success, or error."
|
|
(etaf-data--require-controller controller)
|
|
(let ((request (etaf-data--load-request controller)))
|
|
(etaf-data--signal-condition (plist-get request :condition))
|
|
(plist-get request :result)))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-reload (controller)
|
|
"Reload CONTROLLER and return the source result."
|
|
(etaf-data-load controller))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-mutate (controller operation payload)
|
|
"Run source OPERATION with PAYLOAD, then reload CONTROLLER.
|
|
|
|
Errors are stored in the controller error ref and re-signaled. Return the
|
|
source mutation result after the reload succeeds."
|
|
(etaf-data--require-controller controller)
|
|
(let* ((source (etaf-data--controller-source controller))
|
|
(operation-id (cl-incf etaf-data--operation-id-counter))
|
|
(request-id (1+ (etaf-data--controller-request-id controller)))
|
|
(v2-function (etaf-data--source-mutate-v2-function source))
|
|
(v2-p (functionp v2-function))
|
|
raw-call raw outcome token error-condition normalization-call
|
|
normalization-condition)
|
|
;; The mutation request owns its own loading boundary. A committed
|
|
;; mutation's subsequent reconciliation load receives a new request id.
|
|
(setf (etaf-data--controller-request-id controller) request-id)
|
|
;; Use the same first-class candidate boundary as an ordinary load. This
|
|
;; makes the mutation's observable loading transition atomic and lets a
|
|
;; source inspect the current candidate without exposing a direct live-ref
|
|
;; write as a special case.
|
|
(etaf-data--apply-load-loading controller request-id)
|
|
(setq raw-call
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(if v2-p
|
|
(etaf-data--source-mutate-v2 source operation payload)
|
|
(etaf-data--source-mutate source operation payload)))))
|
|
(setq raw (plist-get raw-call :value)
|
|
error-condition (plist-get raw-call :condition))
|
|
;; Normalize inside the same compatibility boundary as the source call.
|
|
;; A malformed v2 envelope is itself an uncertain external operation: the
|
|
;; adapter was invoked exactly once, but Data cannot safely infer whether
|
|
;; the side effect committed, so it must publish an error and forbid retry.
|
|
(when (and v2-p (not error-condition))
|
|
(setq normalization-call
|
|
(etaf-data--capture-condition
|
|
(lambda () (etaf-data--normalize-mutation-outcome raw t))))
|
|
(setq normalization-condition
|
|
(plist-get normalization-call :condition)))
|
|
(setq outcome
|
|
(if error-condition
|
|
(list :certainty 'external-unknown
|
|
:external-commit-certainty 'external-unknown
|
|
:result nil :mutation-result nil
|
|
:error error-condition
|
|
:operation operation
|
|
:operation-id operation-id)
|
|
(if normalization-condition
|
|
(list :certainty 'external-unknown
|
|
:external-commit-certainty 'external-unknown
|
|
:result nil :mutation-result nil
|
|
:error normalization-condition
|
|
:operation operation
|
|
:operation-id operation-id
|
|
:raw raw)
|
|
(append (if v2-p
|
|
(plist-get normalization-call :value)
|
|
(etaf-data--normalize-mutation-outcome raw nil))
|
|
(list :operation operation :operation-id operation-id)))))
|
|
(setq token
|
|
(etaf-data--make-reconciliation-token
|
|
controller operation-id (plist-get outcome :certainty)
|
|
(or (plist-get outcome :mutation-result)
|
|
(plist-get outcome :result))
|
|
(plist-get outcome :reconciliation-token)))
|
|
(setq outcome (plist-put outcome :reconciliation-token token))
|
|
(setf (etaf-data--controller-mutation-outcome controller) outcome
|
|
(etaf-data--controller-reconciliation-token controller) token)
|
|
(cond
|
|
;; A v1 signal or an explicitly uncertain v2 result cannot be replayed.
|
|
((or error-condition normalization-condition
|
|
(eq (plist-get outcome :certainty) 'external-unknown)
|
|
(eq (plist-get outcome :certainty) 'rolled-back))
|
|
(let* ((failure (or error-condition normalization-condition
|
|
(plist-get outcome :error)
|
|
(list 'etaf-data-error
|
|
(format "ETAF Data mutation %S was %s"
|
|
operation
|
|
(plist-get outcome :certainty)))))
|
|
(published
|
|
(etaf-data--capture-condition
|
|
(lambda ()
|
|
(etaf-data--apply-error
|
|
controller request-id failure token outcome))))
|
|
(projection-condition (plist-get published :condition))
|
|
(candidate (etaf-data--controller-projection-candidate controller))
|
|
;; Preserve the primary source/normalization condition as the
|
|
;; public prefix. A projection/render fault is attached through
|
|
;; the same fixed trailer used by committed reconciliation, while
|
|
;; its raw condition remains available on the opaque token.
|
|
(public-failure
|
|
(if (and projection-condition candidate)
|
|
(progn
|
|
(etaf-data--token-put token :projection-condition
|
|
(etaf-data--projection-condition-prefix
|
|
projection-condition))
|
|
(etaf-data--decorate-projection-condition
|
|
failure candidate))
|
|
failure)))
|
|
;; Preserve the source's original error, if any; otherwise expose the
|
|
;; v2 rollback/uncertainty diagnostic we synthesized above. Do not
|
|
;; discard a projection condition merely because the primary operation
|
|
;; was already known to have failed.
|
|
(etaf-data--signal-condition public-failure)
|
|
(plist-get outcome :mutation-result)))
|
|
(t
|
|
;; Exactly one source mutation has happened. Reconciliation may issue a
|
|
;; load, but it never invokes the mutation callback again.
|
|
(let ((request (etaf-data--load-request controller outcome token)))
|
|
(etaf-data--signal-condition (plist-get request :condition))
|
|
(plist-get outcome :mutation-result))))))
|
|
|
|
(defun etaf-data--reconciliation-candidate (controller)
|
|
"Return CONTROLLER's latest candidate, if any."
|
|
(etaf-data--controller-projection-candidate controller))
|
|
|
|
(defun etaf-data--retry-target-contexts (candidate token)
|
|
"Return currently live failed context IDs for CANDIDATE and TOKEN."
|
|
(let* ((failed (copy-sequence (or (plist-get token :failed-context-ids) nil)))
|
|
(live (etaf-data--projection-context-ids
|
|
(etaf-data--projection-candidate-changed-sources candidate)))
|
|
(target (cl-intersection failed live :test #'eql)))
|
|
(if target target etaf-data--no-contexts)))
|
|
|
|
(defun etaf-data--finish-retry-dispatch
|
|
(_controller candidate token target dispatch &optional deferred-p)
|
|
"Finalize one partial retry and return its dispatch CONDITION, if any."
|
|
(let ((finish
|
|
(lambda (summary)
|
|
(let* ((condition (plist-get summary :condition))
|
|
(attempted (unless (eq target etaf-data--no-contexts) target))
|
|
(failed
|
|
(and attempted
|
|
(etaf-data--projection-failed-context-ids
|
|
candidate summary condition attempted)))
|
|
;; A route can become stale between target selection and
|
|
;; dispatch. It is a skipped context, not a successful one;
|
|
;; retain it as failed until a later live retry can address it.
|
|
(stale
|
|
(and attempted
|
|
(cl-loop for context in (plist-get summary :contexts)
|
|
when (and (memq (plist-get context :context-id)
|
|
attempted)
|
|
(> (or (plist-get context
|
|
:stale-route-drops)
|
|
0)
|
|
0))
|
|
collect (plist-get context :context-id))))
|
|
(failed (cl-union failed stale)))
|
|
(when attempted
|
|
(etaf-data--token-put token :attempt
|
|
(1+ (or (plist-get token :attempt) 0)))
|
|
(etaf-data--projection-mark-token
|
|
candidate summary condition failed attempted t))
|
|
condition))))
|
|
(if deferred-p
|
|
(progn
|
|
(etaf-scheduler-on-projection-complete finish)
|
|
nil)
|
|
(funcall finish (or (plist-get dispatch :summary)
|
|
(list :condition (plist-get dispatch :condition)
|
|
:contexts nil))))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-retry-render (controller)
|
|
"Retry only failed live contexts for CONTROLLER's latest projection.
|
|
|
|
No source mutation is replayed. A controller with no failed contexts, or with
|
|
an `external-unknown'/'rolled-back' mutation outcome, is left untouched and
|
|
returns nil."
|
|
(etaf-data--require-controller controller)
|
|
(let* ((candidate (etaf-data--reconciliation-candidate controller))
|
|
(token (and candidate
|
|
(etaf-data--projection-candidate-reconciliation-token
|
|
candidate)))
|
|
(certainty (and token (plist-get token :certainty))))
|
|
(when (and candidate token
|
|
(eq certainty 'committed)
|
|
(plist-get token :failed-context-ids))
|
|
(let* ((target (etaf-data--retry-target-contexts candidate token))
|
|
(dispatch
|
|
(etaf-data--projection-dispatch candidate target))
|
|
(condition
|
|
(etaf-data--finish-retry-dispatch
|
|
controller candidate token target dispatch
|
|
(plist-get dispatch :deferred-p))))
|
|
(when condition
|
|
(etaf-data--signal-condition
|
|
(etaf-data--decorate-projection-condition condition candidate)))
|
|
(not (eq target etaf-data--no-contexts))))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-retry-reconciliation (controller)
|
|
"Reload a committed mutation without replaying its source mutation.
|
|
|
|
The operation is allowed only for a committed outcome with a pending token;
|
|
unknown and rolled-back outcomes are deliberately not retried."
|
|
(etaf-data--require-controller controller)
|
|
(let* ((outcome (etaf-data--controller-mutation-outcome controller))
|
|
(token (and outcome (plist-get outcome :reconciliation-token))))
|
|
(when (and outcome token
|
|
(eq (plist-get outcome :certainty) 'committed)
|
|
(memq (plist-get token :state)
|
|
'(reconciliation-pending projection-pending render-pending)))
|
|
(etaf-data--token-put token :attempt
|
|
(1+ (or (plist-get token :attempt) 0)))
|
|
(let ((request (etaf-data--load-request controller outcome token)))
|
|
(etaf-data--signal-condition (plist-get request :condition))
|
|
(plist-get request :result)))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-stop (controller)
|
|
"Stop CONTROLLER, dispose its Scope, and return cleanup errors."
|
|
(unless (etaf-data-controller-p controller)
|
|
(signal 'wrong-type-argument (list 'etaf-data-controller-p controller)))
|
|
(unless (etaf-data--controller-stopped-p controller)
|
|
(setf (etaf-data--controller-stopped-p controller) t)
|
|
(etaf-scope-stop (etaf-data--controller-scope controller))))
|
|
|
|
(defun etaf-data-query (controller)
|
|
"Return CONTROLLER's query ref."
|
|
(etaf-data--controller-query (etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-page (controller)
|
|
"Return CONTROLLER's page ref."
|
|
(etaf-data--controller-page (etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-page-size (controller)
|
|
"Return CONTROLLER's page-size ref."
|
|
(etaf-data--controller-page-size
|
|
(etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-items (controller)
|
|
"Return CONTROLLER's loaded items ref."
|
|
(etaf-data--controller-items (etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-total (controller)
|
|
"Return CONTROLLER's total matching item count ref."
|
|
(etaf-data--controller-total (etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-status (controller)
|
|
"Return CONTROLLER's status ref.
|
|
|
|
The status value is one of `idle', `loading', `success', or `error'."
|
|
(etaf-data--controller-status (etaf-data--require-controller controller)))
|
|
|
|
(defun etaf-data-error (controller)
|
|
"Return CONTROLLER's observable error ref."
|
|
(etaf-data--controller-error (etaf-data--require-controller controller)))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-mutation-outcome (controller)
|
|
"Return a copy of CONTROLLER's latest mutation outcome envelope.
|
|
|
|
The envelope contains `:certainty' (`committed', `rolled-back', or
|
|
`external-unknown'), the raw mutation result, and an opaque reconciliation
|
|
token. It is read-only metadata; the v1 mutation return value is unchanged."
|
|
(copy-tree
|
|
(etaf-data--controller-mutation-outcome
|
|
(etaf-data--require-controller controller))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-reconciliation-token (controller)
|
|
"Return CONTROLLER's current opaque reconciliation token, if any."
|
|
(copy-tree
|
|
(etaf-data--controller-reconciliation-token
|
|
(etaf-data--require-controller controller))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-reconciliation-state (controller)
|
|
"Return CONTROLLER's current reconciliation state symbol, if any."
|
|
(let ((token (etaf-data--controller-reconciliation-token
|
|
(etaf-data--require-controller controller))))
|
|
(and token (plist-get token :state))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-projection-candidate (controller)
|
|
"Return a detached snapshot of CONTROLLER's latest projection candidate.
|
|
|
|
Reactive ref identities remain intact for diagnostics, but changing the
|
|
returned struct or its entry metadata cannot mutate the one-shot candidate
|
|
used by Data's commit/retry machinery."
|
|
(let ((candidate
|
|
(etaf-data--controller-projection-candidate
|
|
(etaf-data--require-controller controller))))
|
|
(when candidate
|
|
(etaf-data--projection-candidate-create
|
|
:controller-id
|
|
(etaf-data--projection-candidate-controller-id candidate)
|
|
:request-id
|
|
(etaf-data--projection-candidate-request-id candidate)
|
|
:projection-id
|
|
(etaf-data--projection-candidate-projection-id candidate)
|
|
:dispatch-epoch
|
|
(etaf-data--projection-candidate-dispatch-epoch candidate)
|
|
:kind (etaf-data--projection-candidate-kind candidate)
|
|
:entries
|
|
(mapcar #'copy-tree
|
|
(etaf-data--projection-candidate-entries candidate))
|
|
:changed-sources
|
|
(copy-sequence
|
|
(etaf-data--projection-candidate-changed-sources candidate))
|
|
:certainty (etaf-data--projection-candidate-certainty candidate)
|
|
:mutation-result
|
|
(copy-tree
|
|
(etaf-data--projection-candidate-mutation-result candidate))
|
|
:reconciliation-token
|
|
(copy-tree
|
|
(etaf-data--projection-candidate-reconciliation-token candidate))
|
|
:context-ids
|
|
(copy-sequence (etaf-data--projection-candidate-context-ids candidate))
|
|
:completed-context-ids
|
|
(copy-sequence
|
|
(etaf-data--projection-candidate-completed-context-ids candidate))
|
|
:failed-context-ids
|
|
(copy-sequence
|
|
(etaf-data--projection-candidate-failed-context-ids candidate))
|
|
:state (etaf-data--projection-candidate-state candidate)))))
|
|
|
|
(defun etaf-data-selection (controller)
|
|
"Return CONTROLLER's selected identity list ref."
|
|
(etaf-data--controller-selection
|
|
(etaf-data--require-controller controller)))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-item-identity (controller item)
|
|
"Return ITEM's stable selection identity in CONTROLLER.
|
|
|
|
The identity comes from the Controller's explicit `:item-key', then from its
|
|
source capability, and otherwise is ITEM itself."
|
|
(etaf-data--item-identity (etaf-data--require-controller controller) item))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-selected-ref (controller identity)
|
|
"Return CONTROLLER's stable boolean selection ref for IDENTITY.
|
|
|
|
The returned ref changes only when IDENTITY enters or leaves the controller's
|
|
selection. Repeated calls for the same identity return the same ref for the
|
|
controller lifetime. Updates made through the selection APIs or by writing
|
|
the public `etaf-data-selection' ref directly are both reflected."
|
|
(etaf-data--ensure-selected-ref
|
|
(etaf-data--require-controller controller) identity))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-selected-item (controller &optional item-key)
|
|
"Return the loaded item matching CONTROLLER's first selected identity.
|
|
|
|
ITEM-KEY overrides the function supplied to `etaf-data-controller'. When no
|
|
key function is available, item identity is compared directly. Return nil
|
|
when the selection or current page has no matching item."
|
|
(let* ((controller (etaf-data--require-controller controller))
|
|
(identity (car (etaf-value (etaf-data-selection controller))))
|
|
(items (etaf-value (etaf-data-items controller)))
|
|
(key (or item-key (etaf-data--controller-item-key controller)
|
|
#'identity)))
|
|
(when identity
|
|
(cl-find identity items :key key :test #'equal))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-set-query (controller query)
|
|
"Set CONTROLLER query to QUERY and return QUERY."
|
|
(setf (etaf-value (etaf-data-query controller)) query))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-set-page (controller page)
|
|
"Set CONTROLLER page to PAGE and return PAGE."
|
|
(setf (etaf-value (etaf-data-page controller)) page))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-set-page-size (controller page-size)
|
|
"Set CONTROLLER page size to PAGE-SIZE and return PAGE-SIZE."
|
|
(setf (etaf-value (etaf-data-page-size controller)) page-size))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-next-page (controller)
|
|
"Move CONTROLLER to the next page and return the new page."
|
|
(setq controller (etaf-data--require-controller controller))
|
|
(let ((next (1+ (etaf-value (etaf-data-page controller)))))
|
|
(etaf-data-set-page controller next)
|
|
;; An imperative pager must still refresh a Controller created with
|
|
;; AUTO-LOAD nil. AUTO-LOAD t remains owned by its reactive effect, so
|
|
;; this branch avoids a duplicate source request.
|
|
(unless (etaf-data--controller-auto-load-p controller)
|
|
(etaf-data-load controller))
|
|
next))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-previous-page (controller)
|
|
"Move CONTROLLER to the previous page and return the new page."
|
|
(setq controller (etaf-data--require-controller controller))
|
|
(let ((previous (max 1 (1- (etaf-value (etaf-data-page controller))))))
|
|
(etaf-data-set-page controller previous)
|
|
(unless (etaf-data--controller-auto-load-p controller)
|
|
(etaf-data-load controller))
|
|
previous))
|
|
|
|
;;;###autoload
|
|
(cl-defun etaf-data-select (controller identity &optional (selected-p t))
|
|
"Select or deselect IDENTITY in CONTROLLER.
|
|
|
|
When SELECTED-P is nil, remove IDENTITY from the selection."
|
|
(let* ((selection-ref (etaf-data-selection controller))
|
|
(selection (etaf-value selection-ref)))
|
|
(setf (etaf-value selection-ref)
|
|
(if selected-p
|
|
(cl-adjoin identity selection :test #'equal)
|
|
(cl-remove identity selection :test #'equal)))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-select-one (controller identity)
|
|
"Replace CONTROLLER selection with the single IDENTITY.
|
|
|
|
Use this explicit single-selection operation for tables and list views. The
|
|
existing `etaf-data-select' API remains additive for multi-select controls."
|
|
(let ((selection-ref (etaf-data-selection controller)))
|
|
(setf (etaf-value selection-ref)
|
|
(if (null identity) nil (list identity)))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-selected-p (controller identity)
|
|
"Return non-nil when IDENTITY is selected in CONTROLLER."
|
|
(member identity (etaf-value (etaf-data-selection controller))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-data-clear-selection (controller)
|
|
"Clear CONTROLLER selection and return nil."
|
|
(setf (etaf-value (etaf-data-selection controller)) nil))
|
|
|
|
(provide 'etaf-data)
|
|
|
|
;;; etaf-data.el ends here
|