349 lines
15 KiB
EmacsLisp
349 lines
15 KiB
EmacsLisp
;;; etaf-retirement.el --- ETAF postcommit retirement journal -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Defines run-once public lifecycle entries, bounded idempotent structural
|
|
;; cleanup, append-only diagnostics, and cause-compatible postcommit condition
|
|
;; trailers. Retirement never owns or rolls back committed generation/surface
|
|
;; authority.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'subr-x)
|
|
|
|
(define-error 'etaf-retirement-error "Invalid ETAF retirement journal")
|
|
|
|
(defvar etaf-retirement--journal-id-counter 0)
|
|
(defvar etaf-retirement--entry-id-counter 0)
|
|
|
|
(defconst etaf-retirement--condition-payload-keys
|
|
'(:kind :committed-p :operation-id :outcome-id :generation-id :revision
|
|
:diagnostic-journal-id)
|
|
"Canonical ordered keys in a v1 postcommit condition payload.")
|
|
|
|
(defconst etaf-retirement--projection-payload-keys
|
|
'(:kind :committed-p :external-commit-certainty :reconciliation-token
|
|
:projection-token :result :operation-id :outcome-id :generation-id
|
|
:revision :diagnostic-journal-id)
|
|
"Canonical ordered keys in a v1 data projection condition payload.")
|
|
|
|
(cl-defstruct
|
|
(etaf-retirement-entry
|
|
(:constructor etaf-retirement-entry--create))
|
|
"One stable postcommit retirement action."
|
|
id owner kind payload ordering-key
|
|
(attempt-count 0)
|
|
(max-attempts 1)
|
|
policy
|
|
(state 'pending)
|
|
condition)
|
|
|
|
(cl-defstruct
|
|
(etaf-retirement-journal
|
|
(:constructor etaf-retirement-journal--create))
|
|
"Append-only postcommit retirement and diagnostic journal."
|
|
id operation-id outcome-id generation-id revision
|
|
entries diagnostics
|
|
(state 'open))
|
|
|
|
(cl-defun etaf-retirement-journal-create
|
|
(&key operation-id outcome-id generation-id revision)
|
|
"Create a journal bound to OPERATION-ID and OUTCOME-ID.
|
|
GENERATION-ID and REVISION identify already committed facts."
|
|
(unless (and (integerp operation-id) (>= operation-id 0)
|
|
outcome-id
|
|
(integerp generation-id) (>= generation-id 0)
|
|
(integerp revision) (>= revision 0))
|
|
(signal 'etaf-retirement-error
|
|
(list :invalid-journal-metadata
|
|
operation-id outcome-id generation-id revision)))
|
|
(etaf-retirement-journal--create
|
|
:id (cl-incf etaf-retirement--journal-id-counter)
|
|
:operation-id operation-id
|
|
:outcome-id outcome-id
|
|
:generation-id generation-id
|
|
:revision revision
|
|
:entries nil
|
|
:diagnostics nil))
|
|
|
|
(cl-defun etaf-retirement-enqueue
|
|
(journal &key owner kind payload ordering-key policy max-attempts)
|
|
"Append one retirement entry to JOURNAL.
|
|
OWNER, KIND, PAYLOAD, ORDERING-KEY, POLICY, and MAX-ATTEMPTS describe the
|
|
action."
|
|
(unless (and (etaf-retirement-journal-p journal)
|
|
(eq (etaf-retirement-journal-state journal) 'open)
|
|
owner kind (functionp payload)
|
|
(memq policy '(run-once-public retryable-idempotent
|
|
contained-once))
|
|
(integerp max-attempts) (> max-attempts 0))
|
|
(signal 'etaf-retirement-error
|
|
(list :invalid-entry owner kind policy max-attempts)))
|
|
(let ((entry
|
|
(etaf-retirement-entry--create
|
|
:id (cl-incf etaf-retirement--entry-id-counter)
|
|
:owner owner
|
|
:kind kind
|
|
:payload payload
|
|
:ordering-key ordering-key
|
|
:policy policy
|
|
:max-attempts max-attempts)))
|
|
(push entry (etaf-retirement-journal-entries journal))
|
|
entry))
|
|
|
|
(defun etaf-retirement--ordering-value-rank (value)
|
|
"Return a stable type rank for retirement ordering VALUE."
|
|
(cond
|
|
((null value) 0)
|
|
((numberp value) 1)
|
|
((symbolp value) 2)
|
|
((stringp value) 3)
|
|
((consp value) 4)
|
|
(t 5)))
|
|
|
|
(defun etaf-retirement--compare-ordering-values (left right)
|
|
"Compare retirement ordering values LEFT and RIGHT.
|
|
Return a negative integer when LEFT precedes RIGHT, zero when their ordering
|
|
forms are equal, and a positive integer otherwise."
|
|
(cond
|
|
((equal left right) 0)
|
|
((and (numberp left) (numberp right))
|
|
(cond ((= left right) 0) ((< left right) -1) (t 1)))
|
|
((and (symbolp left) (symbolp right))
|
|
(if (string< (symbol-name left) (symbol-name right)) -1 1))
|
|
((and (stringp left) (stringp right))
|
|
(if (string< left right) -1 1))
|
|
((and (consp left) (consp right))
|
|
(let ((left-tail left) (right-tail right) (result 0))
|
|
(while (and (consp left-tail) (consp right-tail) (= result 0))
|
|
(setq result
|
|
(etaf-retirement--compare-ordering-values
|
|
(car left-tail) (car right-tail))
|
|
left-tail (cdr left-tail)
|
|
right-tail (cdr right-tail)))
|
|
(if (= result 0)
|
|
(etaf-retirement--compare-ordering-values left-tail right-tail)
|
|
result)))
|
|
(t
|
|
(let ((left-rank (etaf-retirement--ordering-value-rank left))
|
|
(right-rank (etaf-retirement--ordering-value-rank right)))
|
|
(cond
|
|
((< left-rank right-rank) -1)
|
|
((> left-rank right-rank) 1)
|
|
((string< (prin1-to-string left) (prin1-to-string right)) -1)
|
|
(t 1))))))
|
|
|
|
(defun etaf-retirement--entry-less-p (left right)
|
|
"Return non-nil when LEFT sorts before RIGHT deterministically."
|
|
(let ((order
|
|
(etaf-retirement--compare-ordering-values
|
|
(etaf-retirement-entry-ordering-key left)
|
|
(etaf-retirement-entry-ordering-key right))))
|
|
(if (= order 0)
|
|
(< (etaf-retirement-entry-id left)
|
|
(etaf-retirement-entry-id right))
|
|
(< order 0))))
|
|
|
|
(defun etaf-retirement--record-failure (journal entry condition terminal-state)
|
|
"Record ENTRY CONDITION in JOURNAL and assign TERMINAL-STATE."
|
|
(setf (etaf-retirement-entry-condition entry) condition
|
|
(etaf-retirement-entry-state entry) terminal-state)
|
|
(push (list :entry-id (etaf-retirement-entry-id entry)
|
|
:owner (copy-tree (etaf-retirement-entry-owner entry))
|
|
:kind (etaf-retirement-entry-kind entry)
|
|
:policy (etaf-retirement-entry-policy entry)
|
|
:attempt-count (etaf-retirement-entry-attempt-count entry)
|
|
:state terminal-state
|
|
:condition (copy-tree condition))
|
|
(etaf-retirement-journal-diagnostics journal)))
|
|
|
|
(defun etaf-retirement--run-entry (journal entry)
|
|
"Run JOURNAL ENTRY according to its bounded policy and return a condition."
|
|
(let (condition done)
|
|
(while (and (not done)
|
|
(< (etaf-retirement-entry-attempt-count entry)
|
|
(etaf-retirement-entry-max-attempts entry)))
|
|
(cl-incf (etaf-retirement-entry-attempt-count entry))
|
|
(setf (etaf-retirement-entry-state entry) 'running)
|
|
(setq condition
|
|
(condition-case failure
|
|
(progn
|
|
(funcall (etaf-retirement-entry-payload entry))
|
|
nil)
|
|
((error quit) failure)))
|
|
(if (null condition)
|
|
(setq done t)
|
|
(unless (eq (etaf-retirement-entry-policy entry)
|
|
'retryable-idempotent)
|
|
(setq done t))))
|
|
(if (null condition)
|
|
(setf (etaf-retirement-entry-state entry) 'completed)
|
|
(etaf-retirement--record-failure
|
|
journal entry condition 'failed-contained))
|
|
condition))
|
|
|
|
(defun etaf-retirement-drain (journal)
|
|
"Drain JOURNAL once and return the first public lifecycle condition."
|
|
(unless (and (etaf-retirement-journal-p journal)
|
|
(eq (etaf-retirement-journal-state journal) 'open))
|
|
(signal 'etaf-retirement-error
|
|
(list :journal-not-open
|
|
(and (etaf-retirement-journal-p journal)
|
|
(etaf-retirement-journal-state journal)))))
|
|
(let ((entries
|
|
(sort (copy-sequence (etaf-retirement-journal-entries journal))
|
|
#'etaf-retirement--entry-less-p))
|
|
public-condition public-failed-p)
|
|
(dolist (entry entries)
|
|
(cond
|
|
((and public-failed-p
|
|
(eq (etaf-retirement-entry-policy entry) 'run-once-public))
|
|
(setf (etaf-retirement-entry-state entry) 'abandoned-contained)
|
|
(push (list :entry-id (etaf-retirement-entry-id entry)
|
|
:owner (copy-tree (etaf-retirement-entry-owner entry))
|
|
:kind (etaf-retirement-entry-kind entry)
|
|
:policy 'run-once-public
|
|
:attempt-count 0
|
|
:state 'abandoned-contained)
|
|
(etaf-retirement-journal-diagnostics journal)))
|
|
(t
|
|
(when-let* ((condition (etaf-retirement--run-entry journal entry)))
|
|
(when (and (eq (etaf-retirement-entry-policy entry)
|
|
'run-once-public)
|
|
(null public-condition))
|
|
(setq public-condition condition
|
|
public-failed-p t))))))
|
|
(setf (etaf-retirement-journal-entries journal) entries
|
|
(etaf-retirement-journal-diagnostics journal)
|
|
(nreverse (etaf-retirement-journal-diagnostics journal))
|
|
(etaf-retirement-journal-state journal) 'completed)
|
|
public-condition))
|
|
|
|
(defun etaf-retirement-record-contained-failure
|
|
(journal owner kind condition)
|
|
"Append contained postcommit CONDITION metadata to JOURNAL.
|
|
OWNER and KIND identify the failed postcommit step. This records evidence
|
|
without rerunning the failed operation or changing committed authority."
|
|
(unless (and (etaf-retirement-journal-p journal)
|
|
(eq (etaf-retirement-journal-state journal) 'open)
|
|
owner kind
|
|
(consp condition) (symbolp (car condition)))
|
|
(signal 'etaf-retirement-error
|
|
(list :invalid-contained-failure owner kind condition)))
|
|
(push (list :entry-id (cl-incf etaf-retirement--entry-id-counter)
|
|
:owner (copy-tree owner)
|
|
:kind kind
|
|
:policy 'contained-once
|
|
:attempt-count 1
|
|
:state 'failed-contained
|
|
:condition (copy-tree condition))
|
|
(etaf-retirement-journal-diagnostics journal))
|
|
condition)
|
|
|
|
(cl-defun etaf-retirement-condition-trailer
|
|
(journal &optional kind &rest options)
|
|
"Return the canonical v1 trailer for JOURNAL and KIND.
|
|
|
|
The legacy POSTCOMMIT form is unchanged. KIND `projection' additionally
|
|
requires the certainty and both reconciliation/projection tokens, which are
|
|
encoded in the same versioned sentinel wire format."
|
|
;; Accept both the historical positional KIND and a keyword-style KIND.
|
|
(when (keywordp kind)
|
|
(setq options (cons kind options)
|
|
kind (plist-get options :kind)))
|
|
(let ((external-commit-certainty
|
|
(plist-get options :external-commit-certainty))
|
|
(reconciliation-token (plist-get options :reconciliation-token))
|
|
(projection-token (plist-get options :projection-token))
|
|
(result (plist-get options :result)))
|
|
(if (eq (or kind 'postcommit) 'projection)
|
|
(list :etaf-condition-trailer/v1
|
|
(list :kind 'projection
|
|
:committed-p t
|
|
:external-commit-certainty external-commit-certainty
|
|
:reconciliation-token reconciliation-token
|
|
:projection-token projection-token
|
|
:result result
|
|
:operation-id (etaf-retirement-journal-operation-id journal)
|
|
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
|
:generation-id (etaf-retirement-journal-generation-id journal)
|
|
:revision (etaf-retirement-journal-revision journal)
|
|
:diagnostic-journal-id (etaf-retirement-journal-id journal)))
|
|
(list :etaf-condition-trailer/v1
|
|
(list :kind (or kind 'postcommit)
|
|
:committed-p t
|
|
:operation-id (etaf-retirement-journal-operation-id journal)
|
|
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
|
:generation-id (etaf-retirement-journal-generation-id journal)
|
|
:revision (etaf-retirement-journal-revision journal)
|
|
:diagnostic-journal-id (etaf-retirement-journal-id journal))))))
|
|
|
|
(defun etaf-retirement--condition-trailer-payload (condition)
|
|
"Return the final validated-looking trailer payload in CONDITION, or nil.
|
|
Validation of kind-specific fields is performed by the public readers."
|
|
(when (and (consp condition) (symbolp (car condition))
|
|
(proper-list-p (cdr condition)) (cdr condition))
|
|
(let ((trailer (car (last (cdr condition)))))
|
|
(when (and (proper-list-p trailer)
|
|
(= (length trailer) 2)
|
|
(eq (car trailer) :etaf-condition-trailer/v1)
|
|
(proper-list-p (cadr trailer)))
|
|
(cadr trailer)))))
|
|
|
|
(defun etaf-retirement--valid-payload-p (payload keys kind)
|
|
"Return non-nil when PAYLOAD exactly matches KEYS and has KIND metadata."
|
|
(and (= (length payload) (* 2 (length keys)))
|
|
(equal (cl-loop for (key _value) on payload by #'cddr collect key)
|
|
keys)
|
|
(eq (plist-get payload :kind) kind)
|
|
(eq (plist-get payload :committed-p) t)
|
|
(integerp (plist-get payload :operation-id))
|
|
(>= (plist-get payload :operation-id) 0)
|
|
(plist-get payload :outcome-id)
|
|
(integerp (plist-get payload :generation-id))
|
|
(>= (plist-get payload :generation-id) 0)
|
|
(integerp (plist-get payload :revision))
|
|
(>= (plist-get payload :revision) 0)
|
|
(integerp (plist-get payload :diagnostic-journal-id))
|
|
(> (plist-get payload :diagnostic-journal-id) 0)))
|
|
|
|
(defun etaf-condition-postcommit-info (condition)
|
|
"Return validated postcommit payload from CONDITION, or nil."
|
|
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
|
(when (and payload
|
|
(etaf-retirement--valid-payload-p
|
|
payload etaf-retirement--condition-payload-keys 'postcommit))
|
|
(copy-tree payload))))
|
|
|
|
(defun etaf-data-condition-projection-info (condition)
|
|
"Return validated v1 Data projection payload from CONDITION, or nil.
|
|
|
|
The reader only recognizes the final datum, preserving arbitrary business
|
|
data and earlier lookalike sentinels."
|
|
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
|
(when (and payload
|
|
(etaf-retirement--valid-payload-p
|
|
payload etaf-retirement--projection-payload-keys 'projection)
|
|
(memq (plist-get payload :external-commit-certainty)
|
|
'(committed external-unknown rolled-back))
|
|
(plist-get payload :reconciliation-token)
|
|
(plist-get payload :projection-token))
|
|
(copy-tree payload))))
|
|
|
|
(defun etaf-retirement-resignal (condition journal)
|
|
"Re-signal original CONDITION with JOURNAL's committed trailer appended."
|
|
(unless (and (consp condition) (symbolp (car condition)))
|
|
(signal 'wrong-type-argument (list 'error-condition condition)))
|
|
(if (etaf-condition-postcommit-info condition)
|
|
(signal (car condition) (cdr condition))
|
|
(signal (car condition)
|
|
(append (copy-tree (cdr condition))
|
|
(list (etaf-retirement-condition-trailer journal))))))
|
|
|
|
(provide 'etaf-retirement)
|
|
|
|
;;; etaf-retirement.el ends here
|