259 lines
10 KiB
EmacsLisp
259 lines
10 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)
|
|
|
|
(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-condition-trailer (journal &optional kind)
|
|
"Return the canonical committed trailer for JOURNAL and optional KIND."
|
|
(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-condition-postcommit-info (condition)
|
|
"Return validated postcommit payload from CONDITION, or nil."
|
|
(when (and (consp condition) (symbolp (car condition))
|
|
(proper-list-p (cdr condition)) (cdr condition))
|
|
(let* ((trailer (car (last (cdr condition))))
|
|
(payload
|
|
(and (proper-list-p trailer)
|
|
(= (length trailer) 2)
|
|
(eq (car trailer) :etaf-condition-trailer/v1)
|
|
(cadr trailer))))
|
|
(when (and (proper-list-p payload)
|
|
(eq (plist-get payload :committed-p) t)
|
|
(eq (plist-get payload :kind) 'postcommit)
|
|
(integerp (plist-get payload :operation-id))
|
|
(plist-get payload :outcome-id)
|
|
(integerp (plist-get payload :generation-id))
|
|
(integerp (plist-get payload :revision))
|
|
(integerp (plist-get payload :diagnostic-journal-id)))
|
|
(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
|