179 lines
7.0 KiB
EmacsLisp
179 lines
7.0 KiB
EmacsLisp
;;; etaf-host.el --- ETAF Host attach/detach authority -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Owns one mounted Runtime's fixed Host authority token and state machine.
|
|
;; Initial v2 attachment registers a bounded TP final marker so attached
|
|
;; authority and buffer publication share one final-accept boundary. Detach
|
|
;; invalidates authority in O(1) before any unbounded retirement work.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'tp-transaction)
|
|
(require 'tp-reactive)
|
|
|
|
(define-error 'etaf-host-authority-error "Invalid ETAF Host authority state")
|
|
|
|
(defconst etaf-host--state-slot 0)
|
|
(defconst etaf-host--token-slot 1)
|
|
(defconst etaf-host--version-slot 2)
|
|
|
|
(cl-defstruct
|
|
(etaf-host-authority
|
|
(:constructor etaf-host-authority--create))
|
|
"Fixed identity and mutable authority slots for one Runtime Host."
|
|
host-id
|
|
mount-epoch
|
|
buffer
|
|
slots)
|
|
|
|
(defun etaf-host-authority-create (host-id mount-epoch buffer)
|
|
"Return detached authority for HOST-ID, MOUNT-EPOCH, and BUFFER."
|
|
(unless (and host-id (integerp mount-epoch) (> mount-epoch 0)
|
|
(bufferp buffer))
|
|
(signal 'etaf-host-authority-error
|
|
(list :invalid-host host-id mount-epoch buffer)))
|
|
(etaf-host-authority--create
|
|
:host-id host-id
|
|
:mount-epoch mount-epoch
|
|
:buffer buffer
|
|
:slots (vector 'detached
|
|
(list 'etaf-host-token mount-epoch (make-symbol "token"))
|
|
0)))
|
|
|
|
(defun etaf-host-authority-state (authority)
|
|
"Return AUTHORITY's current Host state."
|
|
(aref (etaf-host-authority-slots authority) etaf-host--state-slot))
|
|
|
|
(defun etaf-host-authority-token (authority)
|
|
"Return AUTHORITY's current opaque token, or nil after detach."
|
|
(aref (etaf-host-authority-slots authority) etaf-host--token-slot))
|
|
|
|
(defun etaf-host-authority-version (authority)
|
|
"Return AUTHORITY's monotonic registration version."
|
|
(aref (etaf-host-authority-slots authority) etaf-host--version-slot))
|
|
|
|
(defun etaf-host-authority-attached-p (authority)
|
|
"Return non-nil when AUTHORITY is publicly attached."
|
|
(and (etaf-host-authority-p authority)
|
|
(eq (etaf-host-authority-state authority) 'attached)
|
|
(etaf-host-authority-token authority)))
|
|
|
|
(defun etaf-host-authority-accepts-token-p (authority token)
|
|
"Return non-nil when attached AUTHORITY accepts opaque TOKEN."
|
|
(and (etaf-host-authority-attached-p authority)
|
|
(eq token (etaf-host-authority-token authority))))
|
|
|
|
(defun etaf-host-authority-begin-attach (authority)
|
|
"Move detached AUTHORITY into its private attaching state."
|
|
(unless (eq (etaf-host-authority-state authority) 'detached)
|
|
(signal 'etaf-host-authority-error
|
|
(list :begin-attach (etaf-host-authority-state authority))))
|
|
(aset (etaf-host-authority-slots authority)
|
|
etaf-host--state-slot 'attaching)
|
|
authority)
|
|
|
|
(defun etaf-host--slot-write (authority index value)
|
|
"Return one prebuilt TP marker write for AUTHORITY slot INDEX and VALUE."
|
|
(tp-final-marker-slot-write-create
|
|
:target (etaf-host-authority-slots authority)
|
|
:index index
|
|
:value value))
|
|
|
|
(defun etaf-host-authority-stage-attach (authority &optional legacy-p)
|
|
"Stage AUTHORITY attachment and register its final marker.
|
|
When LEGACY-P is non-nil, publish attached state directly after the legacy Ebox
|
|
initial operation and rely on manual framework rollback."
|
|
(unless (eq (etaf-host-authority-state authority) 'attaching)
|
|
(signal 'etaf-host-authority-error
|
|
(list :stage-attach (etaf-host-authority-state authority))))
|
|
(let* ((slots (etaf-host-authority-slots authority))
|
|
(token (etaf-host-authority-token authority))
|
|
(version (etaf-host-authority-version authority)))
|
|
(aset slots etaf-host--state-slot 'provisionally-attached)
|
|
(if legacy-p
|
|
(let ((inhibit-quit t))
|
|
(aset slots etaf-host--state-slot 'attached)
|
|
(aset slots etaf-host--version-slot (1+ version)))
|
|
(tp-transaction-register-final-marker
|
|
:owner-key
|
|
(list 'etaf-host
|
|
(etaf-host-authority-host-id authority)
|
|
(etaf-host-authority-mount-epoch authority))
|
|
:expected-token
|
|
(tp-final-marker-expectation-create
|
|
:target slots :index etaf-host--token-slot :value token)
|
|
:expected-version
|
|
(tp-final-marker-expectation-create
|
|
:target slots :index etaf-host--version-slot :value version)
|
|
:next-values
|
|
(vector
|
|
(etaf-host--slot-write authority etaf-host--state-slot 'attached)
|
|
(etaf-host--slot-write authority etaf-host--version-slot (1+ version)))
|
|
:inverse-values
|
|
(vector
|
|
(etaf-host--slot-write
|
|
authority etaf-host--state-slot 'provisionally-attached)
|
|
(etaf-host--slot-write authority etaf-host--version-slot version))
|
|
:slot-write-count 2
|
|
:operation-key 'tp-vector-slots/v1))
|
|
authority))
|
|
|
|
(defun etaf-host-authority-rollback-attach (authority)
|
|
"Restore failed attaching AUTHORITY to detached, idempotently."
|
|
(pcase (etaf-host-authority-state authority)
|
|
((or 'attaching 'provisionally-attached 'attached)
|
|
(aset (etaf-host-authority-slots authority)
|
|
etaf-host--state-slot 'detached))
|
|
((or 'detached 'terminal) nil)
|
|
(state
|
|
(signal 'etaf-host-authority-error (list :rollback-attach state))))
|
|
authority)
|
|
|
|
(defun etaf-host-authority-finish-attach (authority)
|
|
"Validate and return final-accept attached AUTHORITY."
|
|
(unless (etaf-host-authority-attached-p authority)
|
|
(signal 'etaf-host-authority-error
|
|
(list :finish-attach (etaf-host-authority-state authority))))
|
|
authority)
|
|
|
|
(defun etaf-host-authority-begin-detach (authority)
|
|
"Move attached AUTHORITY into pre-boundary detaching state."
|
|
(unless (etaf-host-authority-attached-p authority)
|
|
(signal 'etaf-host-authority-error
|
|
(list :begin-detach (etaf-host-authority-state authority))))
|
|
(aset (etaf-host-authority-slots authority)
|
|
etaf-host--state-slot 'detaching)
|
|
authority)
|
|
|
|
(defun etaf-host-authority-invalidate (authority)
|
|
"Invalidate AUTHORITY token in O(1) and enter detached retirement."
|
|
(unless (memq (etaf-host-authority-state authority)
|
|
'(detaching attaching provisionally-attached detached))
|
|
(signal 'etaf-host-authority-error
|
|
(list :invalidate (etaf-host-authority-state authority))))
|
|
(let* ((slots (etaf-host-authority-slots authority))
|
|
(version (etaf-host-authority-version authority))
|
|
(inhibit-quit t))
|
|
(aset slots etaf-host--state-slot 'detached-retiring)
|
|
(aset slots etaf-host--token-slot nil)
|
|
(aset slots etaf-host--version-slot (1+ version)))
|
|
authority)
|
|
|
|
(defun etaf-host-authority-finish-detach (authority)
|
|
"Move detached-retiring AUTHORITY to terminal."
|
|
(unless (memq (etaf-host-authority-state authority)
|
|
'(detached-retiring terminal))
|
|
(signal 'etaf-host-authority-error
|
|
(list :finish-detach (etaf-host-authority-state authority))))
|
|
(aset (etaf-host-authority-slots authority)
|
|
etaf-host--state-slot 'terminal)
|
|
authority)
|
|
|
|
(provide 'etaf-host)
|
|
|
|
;;; etaf-host.el ends here
|