From 0a72eb836c05d821228e91176282bb75e9487a02 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 25 Jun 2026 09:06:26 -0400 Subject: [PATCH 01/16] WIP starting first mechanization --- .../Test/Leios/RefModel/Spec.md | 979 ++++++++++++++++++ 1 file changed, 979 insertions(+) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md new file mode 100644 index 0000000000..705fdb55df --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md @@ -0,0 +1,979 @@ +# Leios single-node fetch — reference spec (prose) + +**Status:** draft for review (prose §1–§4; §6/§7 appendices). Written autonomously; anticipated additions in §5. + +**Scope.** A single Leios node's logic, centered on the LeiosFetch decision logic, cast +wide enough to cover the single-node subsystem managing multiple, possibly-adversarial, +coming-and-going peers. Stops just above the mini-protocol codecs/multiplexing; does not +model the diffusion layer's churn decisions (churn arrives as events). Deliberately +diverges from the implementation; the implementation will match this design eventually. + +**Conventions.** `EB` = endorser block (point: slot + hash). A closure of an EB = all txs +its body references — by `TxHash`, the hash of the *entire* tx (we avoid `TxId`, which +connotes hashing only the tx body). A job = a batch of an EB's txs of ≈ `jobSize` bytes — the unit of tx +fetching. An election = `(slot, stake-pool id)`. EBs are identified four ways, by need: `EbHash` (the hash — +content identity, for body/tx fetch and offers); `EbRealPoint = (slot, EbHash)` (adds the slot, for +slot-indexed location/GC); `Election = (slot, pool)`; and `HeaderHash` (an announcement's identity — and a +cert's identity, since a cert binds to its `RbHeader`, not merely the `EbHash` it names). An announcement is +an `RbHeader` (it announces an EB and declares its body and +closure sizes); `HeaderHash` is its hash, and the whole header travels on the wire and is validated +(signature/KES, etc.) on receipt — `ebHash`, `bodySize`, and `closureSize` are read from the validated +header. `election(header)` reads an announcement's election from its header; a bare `EbHash` does not +determine its `Election` (the pool lives only in the header), so recovering it is a lookup — needed only +when ingesting an offer (`electionOf`, §2). Two announcements with the same election but +different headers are an equivocation. A certificate (cert) certifies one EB per election (the +certified EB); under honest-majority stake distribution and anti-equivocation voting rules at most one EB per election is +certifiable. Peers are upstream and classified (`BEH-PeerClass`). Sizes in bytes. "Stored"/"persisted" +throughout means a write is readable by this process's other components (intra-process visibility) — what the +consumer-facing fan-out waits for, not ACID "durable". Behaviors +are named (PascalCase code names) rather than numbered, and grouped by mini-protocol: +**LeiosNotify** (announcements, offers, certs, votes), **LeiosFetch** (transferring bodies, +jobs, certs), **startup/shutdown** (the state that must survive a restart), and **everything else** (cross-cutting). + +**Baseline vs skew fallback.** The baseline assumes timing is benign: clock skew and `L_hdr` hold +well enough that the certified EB for an election is always the one a node saw announced first (an +equivocated election simply never certifies). The cert-handling machinery beyond that — the skew +fallback, tagged **[SF]** — is split by how much complexity it adds. A *minimal* +part is sprinkled occasionally through the main spec, just enough to enable a fully syncing or briefly-offline node, even under benign timing. The *full* +part is collected in the §6 appendix; it treats certs as first-class Leios messages, which can reduce the latency and increase the thoroughness of the minimal machinery. Read the main spec first; its inline +**[SF]** tags point to §6 wherever the main spec already includes some minor extraneous parts merely to leave room for the full SF mechanisms. + +--- + +## §1 Behaviors to cover + +### LeiosNotify + +- **`BEH-Wanting`** (client; announcement-gated, anti-equivocation). `LevBlockAnnouncement(peer, header)`: a peer + relays the `RbHeader` announcing that EB `ebHash` exists for its election and declaring its body and closure + sizes. We validate the whole header (signature/KES, etc.) on receipt — hence it travels in full, not just + `ebHash`/sizes. A LeiosNotify header must actually announce an EB; one that announces none is a junk + LeiosNotify message — disconnect. (Contrast ChainSync: a `LevRollForward` header that announces no EB is a + normal block, no disconnect — it just has no announcement effect.) Centrally we keep the first EB announced per election; + an announcement naming a different EB for the same election is an equivocation, kept once as + proof but never wanted. An EB is wanted iff it is that first-announced EB for some election (and not yet + complete, nor below the immutable tip). This bounds the want-set by the number of elections + (sortition-rate-limited), not by adversary offers. Per upstream peer we also bound the + announcement stream: at most two announcements per election — the first, then at most one + equivocation (different-header); a duplicate or + a third is misbehavior — disconnect. All sizes come + from announcements — known up front, before any body/tx arrives, enabling fetch budgeting and + size-validation (`BEH-Responses`). A validated cert (ChainSel's `LevCertValidated`) + also makes its EB wanted; **[SF]** when it names an EB other than our first-seen, the want + switches to the certified EB — skew fallback (§6). + +- **`BEH-Offers`** (client; availability). `LevBlockOffer(peer, ebHash)` / `LevBlockTxsOffer(peer, ebHash)` (LeiosNotify), + `LevRollForward(peer, header)` (ChainSync; `header` announces `ebHash`): `peer` has `ebHash`'s body / full closure; a closure + offer implies a body offer. Offers carry no size (sizes come from announcements). Junk-offer + defense, judged per peer: a LeiosNotify offer is legitimate only for the first EB `peer` announced + for an election (**[SF]** §6 also admits its cert-asserted EB, via `LevCertOffer`); an + equivocation proof from `peer` does not add an offerable EB. An offer for anything else ⇒ disconnect `peer`. Otherwise + record availability (bounded — see `LstPeerOfferings`, §2). (So an honest `peer` offering what it saw + first is fine even when that's our equivocation — it's `peer`'s first; we record it, no disconnect.) + Honest peers never trip the disconnect, because `BEH-NotifyServe` obeys offer-only-if-announced: + the announcement precedes the offer on our connection to `peer`. + ChainSync offers (`LevRollForward`) are a backstop body+closure offer — the peer has `ebHash` + on its chain — fundamental while a node is syncing (peers don't re-offer historical EBs over + LeiosNotify) and useful right after a brief partition/eclipse. Bounded per `(peer, election)` + (latest wins), so a peer churning its header chain cannot accumulate offers. (**[SF]** §6 reads + this as a cert assertion: the offered EB is the certified one, with precedence over a LeiosNotify + offer.) + +- **`BEH-NotifyServe`** (server). Each downstream peer has a notification queue + (`LstPeerNotifyQueue`) the node feeds as it receives announcements/certs and completes closures. A credit + (`MsgLeiosNotificationRequestNext`) from the peer raises the queue's capacity by one; the server + sends the highest-priority entry whenever the queue is non-empty and sending isn't otherwise + blocked. + The queue is back-pressure, not a buffer: its capacity is the peer's outstanding credits, and + producing into a full queue evicts the lowest-priority entry (which may be the new one). + Honest peers keep hundreds of credits outstanding, so their queues never fill. The shared + `notifyPriority` rule (§2) is evaluated against the current `now` at each send and eviction — it is + time-varying, so the queue keeps no stored order (§2). Relay, from the central state: + the first announcement when it first arrives; on equivocation, an equivocation proof (carrying + the equivocating header always, and the first only when the node has not already sent this + peer the first, `LstPeerOfferGates[peer][el] ≠ ebHash₁`). (**[SF]** §6 adds the cert relay — a `MsgLeiosCertOffer` for a + certified EB — and suppresses an equivocation proof once the election is certified.) Because the + announcement state advances at most twice per election, the server never attempts more than that + to any peer, and needs no per-peer announcement count — only `LstPeerOfferGates` for offer-gating. Offers: + enqueue an offer for `ebHash` to a peer only once the node has stored the artifact at the + offered level (`BEH-Completion`) — its body for a body offer, its full closure for a closure + offer — and `ebHash`'s gate is open for that peer (`LstPeerOfferGates[peer][el] = ebHash`, `el` its election). Never offer before that + level's artifact is stored nor before the gate is open (persist-before-expose / + offer-only-if-announced); the gate is what lets clients (`BEH-Offers`) safely disconnect on + offers for + never-announced, never-certified EBs. + +### LeiosFetch + +- **`BEH-BodyFetch`** (any class, no multiplicity limit). While we lack `ebHash`'s body, request + the whole body from every peer that offers it. No cap on how many peers + we body-fetch the same `ebHash` from simultaneously. + +- **`BEH-ChunkJobs`** (TxCache/Mempool-deduped). When `ebHash`'s body first arrives, split `txset(ebHash)`: + the TxCache hits (`txCacheOnBody`, §7) are not fetched — `dbCopyFromTxCache` pulls them into `ebHash`'s + closure; a tx the Mempool holds (`mempoolQueryPresent`; read directly but un-owned — §2) is copied in and + offered to the TxCache (`txCacheOnAcquire`); the rest are partitioned into jobs of ≈ + `jobSize` (e.g. 64 or 128 kB — parameter). If that leaves no jobs — the TxCache/Mempool already + held all of `txset(ebHash)` — then nothing is fetched and `ebHash` is complete as soon as its body and + those cache-reads (its whole closure) are stored (`BEH-Completion`). The LeiosFetch logic treats each EB's txs + independently — it does not track which other EBs share a tx. So the cache only saves work + for EBs whose bodies arrive after the tx is cached; if N EB bodies missing the same + uncached tx arrive before that tx does, it'll be fetched N times (recall that the adversary always has the option to issue EBs that don't overlap at all). + +- **`BEH-ClosureFetch`** (class-dependent, no multiplicity limit), once we've decided the jobs for `ebHash`: + - Stake-sampled offerer of the closure → immediately request every not-yet-received job of + `ebHash` from them. + - PeerSharing-sampled offerer of the closure → request not-yet-received jobs up to ≈ + `peerSharingClosureByteLimit` (~1 MB) in flight to that peer for that closure, choosing jobs whose + txs are currently in-flight with the fewest peers (rarest-first); as responses arrive, + send more requests to refill back toward the limit, using a low/high-water scheme to avoid constant churn. + +- **`BEH-Responses`.** Body: validate hash and size against the announcement; store; chunk into jobs + (`BEH-ChunkJobs`). Job: validate (the job's txs' hashes/sizes); insert the txs into the + TxCache (for future EBs) and mark this EB's job received. No cross-EB completion sweep — + only this EB's state advances. + +- **`BEH-Completion`** (+ fan-out). `ebHash` is complete when both its body and its closure (the txs its + body references) are stored (Conventions). The logic tracks `ebHash`'s remaining txs, so it knows in-memory — no disk query — the + instant the last part is in hand: either the last outstanding job's txs arriving (`LevBlockTxs`), + or, when `BEH-ChunkJobs` finds the TxCache/Mempool already held everything, at chunk time (no jobs + to await). Completion lands when those writes do (`LevDiskDone`). Fan out: immediately the fetch + side stops pursuing this EB; after the write lands, expose `ebHash`'s closure to the disk-reading + consumers — offering it to downstream peers (`BEH-NotifyServe`), voting, and notifying + ChainSel: it must be told that `ebHash`'s closure is now available (readable in the store), since it + may have a block whose adoption was waiting on exactly that closure, and the notification lets it + (re)process such a block (its acquired-set/reprocess machinery is out of the fetch core, §1 + below). (persist-before-expose.) + +- **`BEH-FetchPriority`** (which EBs first). Certified EBs (a validated cert, via + `LevCertValidated`) outrank all uncertified ones, regardless of slot. Within each tier: + uncertified → FreshestFirst (highest slot — stay current near the tip, ready to vote); + certified → FreshestLast (lowest slot), deferring to the common case — a syncing node, where + the pending certified EBs lie on one chain, so oldest-first fills the gap from the front and + unblocks ChainSel's contiguous adoption; across forks (rare, and few certs pend then) it can + misorder. (Prioritization bites via the per-peer active-EB cap (§3): when a peer is at its cap, this + ordering picks which of its offered-and-wanted EBs occupy the slots.) TODO: the exact order is really ChainSel's to drive — it knows which chain it is + adopting and which closure it needs next — so a ChainSel→LeiosFetch signal would supersede this + heuristic. + +- **`BEH-Timeout`.** A generous per-request timeout (≈ today's BlockFetch client timeout). It + targets buggy/overloaded/dead peers, not adversaries. On timeout: `disconnectFrom(peer)`. + +- **`BEH-FetchServe`** (server). On a downstream request for an EB body or (parts of) a closure + (**[SF]** §6 adds certs): if the store has it, serve it; else disconnect that peer (a well-behaved + downstream peer only requests what we advertised). Any freshest-EB caching lives inside the + disk/TxCache IO layer — the server logic is intentionally unaware. + +### Startup/Shutdown + +The durable record across a restart is the disk store (bodies and txs; **[SF]** certs) and the chain +(ChainDB — owned elsewhere — which holds the CertRBs). Every per-peer state variable +(`LstPeerFirstAnnouncements`/`LstPeerOfferings`/`LstPeerOfferGates`/`LstPeerNotifyQueue`/`LstPeerInflight`/`LstPeerPresent`) +is connection-scoped — gone on shutdown, rebuilt as peers reconnect. + +- **`BEH-Shutdown`.** Flush outstanding store writes so every acquired body and tx (both EB closures and TxCache) (**[SF]** cert) + is on disk, and persist the TxCache window (§7). Nothing else of Leios's own state is persisted. +- **`BEH-Startup`.** Begin with empty per-peer state (peers (re)connect via `LevPeerAdd`); rebuild the TxCache + from its persisted window and GC it against the wall clock (§7) *before* pruning the store; prune everything below the current immutable tip (`BEH-TipAdvance`). The + central want/cert/announce state (`LstWanted`/`LstCertified`/`LstFirstAnnouncements`) is re-derived, not + persisted — ChainSel re-validates the CertRBs on our selected chain (re-emitting + `LevCertValidated`) and re-delivers their announcements (`LevRollForward`), and gossiped-only + announcements are re-heard as peers reconnect. (TODO: `BEH-Startup` could also traverse *every* + CertRB in the ChainDB — including volatile-fork blocks ChainSel won't replay at startup — to + recover their certs too; whether that's worthwhile is open.) Re-deriving the want-set consults the + store via `dbQueryPresent` (`BEH-Startup` is its principal caller), so an already-complete EB is not re-fetched. + +### Everything else + +- **`BEH-PeerClass`.** Every upstream peer is either Stake-sampled (drawn from the stake + distribution) or PeerSharing-sampled (drawn from Peer Sharing). The class is fixed for the + connection's lifetime. The two classes are never conflated in any limit or count. + +- **`BEH-PeerChurn`.** Three lifecycle events per peer connection. `LevPeerAdd(peer, class)`: allocate + empty per-peer state. `LevPeerWindDown(peer)`: the diffusion layer is gracefully terminating the + connection — where `peer` is upstream (we fetch) issue it no new requests; where `peer` is downstream + (we serve) stop feeding `LstPeerNotifyQueue[peer]`; but keep `peer`'s outstanding in-flight requests so their + responses can still land (the diffusion layer time-bounds the drain; our per-request + `BEH-Timeout` bounds it independently). `LevPeerRemove(peer)`: the connection is gone — its + mini-protocols are torn down, so no further message from `peer` can physically arrive — drop all + of `peer`'s per-peer state; its outstanding `LstPeerInflight` requests will simply never be answered, + which is harmless (nothing is shared across peers). The graceful path is `LevPeerWindDown` then + `LevPeerRemove` after the peer drains; an abrupt `LevPeerRemove` (the peer died) skips the wind-down. + +- **`BEH-TipAdvance`** (immutable tip → slot `s`). Schedule disk GC (drop volatile data below the new tip) + and promote (copy the now-immutable data from volatile storage to the immutable store), then range-delete + every slot-indexed state variable below the tip. This GC imposes a constraint on almost all of the + state: each retained state variable must be slot-indexed so the prune is an index-accelerated + range-delete `[.., s)`, never a scan. So the `Election`-keyed state variables — LeiosNotify + `LstFirstAnnouncements`/`LstPeerFirstAnnouncements`/`LstPeerOfferings`/`LstPeerOfferGates` (**[SF]** §6's `LstAnnouncedCert`) and LeiosFetch + `LstWanted`/`LstCertified` — range-delete on their slot-major key. Two things sit outside this discipline: + the TxCache is not tip-pruned at all — it has its own window/age eviction (§7); and `LstPeerInflight` is + not slot-GC'd — responses and `LevPeerRemove` reclaim it (a `BEH-Timeout` disconnects, triggering + `LevPeerRemove`, §2). + +- **`BEH-Adversarial`** (peers). Offer-then-withhold, equivocate, lie about sizes/certs, send + unrequested/garbage, or churn a header chain through many equivocating EBs. The node stays + safe (no corruption; PeerSharing peer's per-closure byte limit and the per-peer active-EB cap respected; one cert + per election; `LstPeerOfferings` bounded to ≤2 EBs per peer-election) and live (no-multiplicity-limit + body/stake-closure/cert fetching means an honest offerer always gets us the data; the generous + timeout disconnects dead peers). Announcement-gating (`BEH-Wanting`) bounds the want-set to + the number of elections, so an adversary cannot inflate it via offers. + +- **`BEH-SelfIssued`** (this node's block issuer). When our own issuer produces an EB, it enters via the peerless + `LevSelfIssued(header, body)` stimulus (§3) — fed to the fetch logic as if announced-and-received locally: the + EB announcement and its body "arrive". `BEH-Wanting` records + it like any first announcement, then `BEH-ChunkJobs` splits its `txset` — and since we built the EB from our + own Mempool, those txs are there (modulo a Mempool-churn race), so the closure is acquired *en passant* via + the Mempool path (`mempoolQueryPresent` → `txCacheOnAcquire`), completing the EB with no fetch. Thereafter it + diffuses, is served, and is voted on like any other EB. (The issuer's internal logic — EB construction, + sortition — is out of scope; this is just the hand-off into this document's machinery.) + +**Out of the fetch core** (effect interfaces + boundary events): disk store; notifying ChainSel that +an EB closure is acquired (its acquired-set/reprocess machinery); GC/promote bodies; voting. The ChainSync↔Leios bridge is not +modeled here. A ChainSync `MsgRollForward` delivers one RB `header`; the bridge echoes it as the stimulus +`LevRollForward(peer, header, predEb)`, enriching the wire payload with the predecessor's announced-EB +identity (`predEb` — just the relevant parts: its `HeaderHash`, EB hash, and election, from the preceding `HeaderState`) +— needed because the cert-bit case below certifies the EB the predecessor announced, which `header` alone +does not provide. Regardless of its cert bit, `header` +announces the RB's own EB `ebHash` (`BEH-Wanting`), +updating the central `LstFirstAnnouncements` but not `LstPeerFirstAnnouncements`, which is specific to LeiosNotify. When the cert +bit is set, the RB's body certifies the earlier EB `ebHash′` that `predEb` identifies: the peer offers `ebHash′`'s body+closure +(`BEH-Offers`, a backstop to LeiosNotify), and — separately — ChainSel validates that cert on first +processing the CertRB and emits `LevCertValidated(headerHash′, ebHash′)`, which makes `ebHash′` +wanted. **[SF]** §6's `BEH-CertFetch` is the other emitter of `LevCertValidated`, from a cert +offered via `LevCertOffer`. + +--- + +## §2 State + event alphabet + +### Genuine state (the minimal core) + +LeiosNotify: +- `LstFirstAnnouncements : Election ↦ AnnState`, `AnnState = One RbHeader | Two RbHeader RbHeader` — + the first accepted announcement, plus the first equivocation, if any, once seen; in `Two` the left + header is by convention the older, first-announced one. Drives `BEH-Wanting` and the + server relay `BEH-NotifyServe`. +- `LstPeerFirstAnnouncements : Peer ↦ Election ↦ AnnSeen`, `AnnSeen = One HeaderHash | Two HeaderHash` — the ≤2 + announcement headers this peer sent; the ≤2 bound and equivocation-disconnect derive from it. + (**[SF]** §6: a peer's cert assertion lives in `LstPeerOfferings`'s `CertSide`.) +- `LstPeerOfferings : Peer ↦ Election ↦ These CertSide OfferSide` — availability; `These` makes the + all-empty entry simply absence, with no meaningless empty record. `OfferSide = Body | + BodyAndClosure` is the LeiosNotify offer level. `CertSide = Cert HeaderHash EbHash CertNotificationSeen` — the + announcement (`HeaderHash`) a peer claims a cert for (the cert's identity, for `BEH-CertFetch`) and the `EbHash` + it thereby offers; the offered EB is the `CertSide` EB if present, else the first-announced. A + `LevRollForward` records `These (Cert headerHash ebHash _) BodyAndClosure` (latest wins), so a peer churning its + header chain cannot accumulate offers. **[SF]** The `CertNotificationSeen` flag is set only by §6's + `LevCertOffer`; when set, §6 reads `CertSide` as a cert assertion rather than as plain availability. +- `LstPeerOfferGates : Peer ↦ Election ↦ EbHash` — per downstream peer and election, the one EB + whose gate is open (the EB we announced to that peer; **[SF]** §6 pivots it to the certified EB). + Election-keyed, so GC range-deletes on the slot-major key. It gates offers + (`offer-only-if-announced`): we offer `peer` an EB `ebHash` (at election `el`) only when `LstPeerOfferGates[peer][el] = ebHash`. + It does not gate announcement-sending — `LstFirstAnnouncements` already does that; `BEH-NotifyServe` + skips an EB offer if its gate here isn't yet open. +- `LstPeerNotifyQueue : Peer ↦ Set Notification` — per-downstream-peer pending notifications; capacity = + that peer's outstanding credits. Because `notifyPriority` depends on `now` (§ Helper functions), there is + no fixed order to store and keep sorted: it is an unordered set, and priority is evaluated at the only two + moments it is consulted — sending removes the `notifyPriority(now, ·)`-max, and producing into a full set + evicts the `notifyPriority(now, ·)`-min (which may be the entry just produced). The order between two + pending notifications can therefore flip with nothing but the passage of time, so neither operation may + trust a previously-computed order. + +LeiosFetch: +- `LstWanted : Election ↦ WantState` — deduped by election: at most one wanted EB per election, so + GC range-deletes on the slot-major key. An election enters via its first `LevBlockAnnouncement` or via a + validated cert (`LevCertValidated`), so `dom(LstWanted) + ⊆ dom(LstFirstAnnouncements) ∪ dom(LstCertified)`. `WantState = AwaitingBody { ebHash, bodySize, closureSize } | + AwaitingTxs { ebHash, closureSize, jobs : NonEmpty (JobId ↦ Job) }` — `ebHash : EbHash` names which EB of the + election is wanted (**[SF]** a cert can switch it in place). Over all of time, `LstWanted[el].ebHash` takes + at most two distinct values, because its two insertion sources each name one: the first announcement + names its EB (later, different-EB announcements are equivocations, never wanted), and a + validated cert names the certified EB (at most one EB per election is certifiable, by honest-majority + anti-equivocation). + They coincide in the baseline; **[SF]** skew is the only way the cert's EB differs from the first-announced. + `AwaitingTxs.jobs` holds only the + outstanding jobs (a job is removed once its `LevBlockTxs` arrives) and is non-empty: when the last job's + response would empty it, `complete(el)` runs and removes the `el` entry instead, so an `AwaitingTxs` never + rests with no jobs. `Job = { txs : NonEmptySet TxHash }`, txs fixed at chunk time (§5 would shrink it as + constituent txs arrive by other means). Cached txs (`BEH-ChunkJobs`) never become jobs, so they are + implicitly on hand. +- `LstCertified : Election ↦ (HeaderHash, EbHash)` — validated cert per election (grown by `LevCertValidated`): + the certified announcement's `HeaderHash` paired with its `EbHash`, one per election. The `EbHash` is the + `BEH-FetchPriority` source and the wanted EB; the `HeaderHash` is the cert's identity, against which a + conflicting cert claim is rejected (the cert-conflict disconnect, §3/§6). In the baseline the `EbHash` + always equals the first-seen; **[SF]** it may differ only when timing misbehaved (§6). +- `LstTxCache` — a bounded cross-EB tx dedup cache; load-bearing for throughput (§7), with sound membership; + recall bounded by a space–time trade-off (the window bounds resources, reuse beyond it re-fetches). Its in-memory index (`TxHash → (refcount, acquired)`) + + `≤128`-announcement window, membership, two-trigger eviction, separate backing store, and persistence are + all isolated in §7; the main spec only calls its hooks (`txCacheNoteAnnouncement` / `txCacheOnBody` / + `txCacheOnAcquire` / `dbCopyFromTxCache`). +- `LstPeerInflight : Peer ↦ Seq Req` (a FIFO), `Req = ReqBody Election EbHash | ReqJob Election EbHash JobId` + **[SF]** `| ReqCert Election HeaderHash` (a cert binds to an announcement, so it is keyed by `HeaderHash`, not `EbHash`) — the LeiosFetch protocol delivers replies in request-issue order + (at least today), so a response matches the front of the sequence, which is popped and used to validate + it, never against current `LstWanted`: if the want moved + on after we sent the request (cert switch, tip advance), the peer's reply is still valid, and it's + our doing — not the peer's — that we no longer want it, so we drop the result without + disconnecting. The `Election` is carried only so the handler can advance `LstWanted[el]` (a write) in + O(log n). Each `Req` is tagged with its issue time (for `BEH-Timeout`). Not slot-GC'd — reclaimed by a + matching response, or by `LevPeerRemove` (which a `BEH-Timeout` triggers, via `disconnectFrom`); the §5 stagger clock is EB age, not this. + +Shared: +- `LstPeerPresent : Peer ↦ { class : Class, phase : Phase }`, `Class = StakeSampled | PeerSharingSampled` + (`BEH-PeerClass`), `Phase = Active | WindingDown`. A peer is `Active` from `LevPeerAdd` until + `LevPeerWindDown` flips it to `WindingDown` (the diffusion layer is gracefully terminating it); while + winding down we issue it no new requests but keep its outstanding `LstPeerInflight` until answered or + timed out. + +### Derived (NOT stored — recomputed; deferred to incrementalization) + +LeiosNotify: +- `electionOf : Peer ↦ EbHash ↦ NonEmptySet Election` — per peer, the elections for which `peer` + (first-)announced (**[SF]** or cert-asserted) an EB hashing to `ebHash`. The offer-ingestion index: a + bare-`ebHash` offer is *validated* by `electionOf[peer][ebHash]` being non-empty (else junk ⇒ disconnect) + and *recorded* into `LstPeerOfferings[peer][el]` for each `el` in that set — the body/closure is + content-addressed, so holding it serves every election that peer named it for. A derived cache of + `LstPeerFirstAnnouncements` (+ the headers it references), GC'd in lockstep: as an election ages below the + immutable tip and is range-deleted there, it is removed from its first-announced `ebHash`'s set, and the + `ebHash` key disappears when the set empties (`NonEmptySet ⇒ absence`). This is the one place a bare + `EbHash` is mapped back to an `Election`. +- `offerersBody(ebHash)` / `offerersClosure(ebHash)` = peers `peer` for whom some `LstPeerOfferings[peer][el]` + (`el ∈ electionOf[peer][ebHash]`) has an + `OfferSide` (`Body` or `BodyAndClosure` / exactly `BodyAndClosure`) and whose offered EB (the + `CertSide` EB if present, else `peer`'s first-announced) is `ebHash`. These are reverse indexes of + `LstPeerOfferings`: they invert its forward `Peer ↦ Election ↦ …` shape to answer EB → the set of peers + offering it (at that level), which is the direction the fetch loop queries — so incrementalization + maintains the inversion as a stored `EbHash ↦ NonEmptySet Peer` index rather than rescanning every peer + (an EB with no offerers is simply absent — no empty value rests in the index). + +LeiosFetch: +- `jobInflightPeers(ebHash, j) = |{ peer | ReqJob _ ebHash j ∈ LstPeerInflight[peer] }|` (job-level rarest-first + §5 stagger) +- `activeEbs(peer) = |{ ebHash | some Req for ebHash ∈ LstPeerInflight[peer] }|` (per-peer active-EB cap, §3) +- `peerSharingInFlightBytes(peer, ebHash) = Σ job sizes for ReqJob _ ebHash _ ∈ LstPeerInflight[peer]` (PeerSharing peers' ~1 MB limit) +- (There is no reverse `tx ↦ {EB}` index, because cross-EB membership is deliberately not tracked; `BEH-ChunkJobs`/`BEH-Responses`.) + +Discipline. Nothing in this section is stored — it is all recomputed from the genuine core on demand. The +core is deliberately kept information-complete: every derived quantity here is a pure function `f` of the +core, so the core never drops anything a cache would need, and no cache is ever folded back into the core. +That makes incrementalization a mechanical, later step — to make some `f` fast, add a stored field holding +its value, declare the invariant `cache == f(core)`, and re-establish that invariant in every rule that +writes the core. So the spec stays simple now, and the optimized implementation is a faithful refinement of it. + +### Helper functions (pure; not state) + +- `notifyPriority(now, notification)` — a pure comparator giving a total order on notifications against the wallclock + `now`: announcements for EBs younger than `L_hdr` > announcements for EBs younger than `3·L_hdr` > + everything else (older announcements, certs, offers, votes); within a tier, higher EB slot (fresher) wins. + Because the tiering is relative to `now`, the order slides as the clock advances — a fresh announcement + outranks a bottom-tier cert now, yet once it ages past `3·L_hdr` the higher-slot cert overtakes it — so it + is recomputed per comparison rather than cached, and any `notifyPriority`-ranked collection (e.g. + `LstPeerNotifyQueue`) is consulted only when acting, never via a stored order. Shared by the + `LstPeerNotifyQueue` dequeuer and every enqueuer (`BEH-NotifyServe`). + +### Behind the disk store interface (dumb; shared) + +`dbWriteBody` · `dbWriteTxsIntoClosure` · **[SF]** `dbWriteCert` · `dbQueryPresent(keys)` (which of those +bodies/txs/**[SF]** certs the store holds) · `dbGarbageCollect(slot)` · `dbPromote(point)` — presence facts +only; no EB↔tx knowledge, no completion, no broadcast, so the logic composes EB-completeness (body present ∧ +all closure txs present) from these. The TxCache is a separate component (§7); the main spec reaches it only +through its hooks, and `dbCopyFromTxCache(txs)` (in `BEH-ChunkJobs`) copies cache hits into the closure. + +### Reads of un-owned state + +The **Mempool** belongs to another component; the logic only *reads* it and never mirrors it — +subscribing to its every change would merely maintain a pointless private copy. `BEH-ChunkJobs` +reads it via `mempoolQueryPresent(txs)` (which of those txs the Mempool holds; a hit is offered to the +TxCache, `txCacheOnAcquire` §7, and thereafter treated as cached) to skip fetching txs the node already +holds. This is the one place the logic reads another component's live state directly rather than via +messages; unlike `Lst…` state, we neither own nor GC it. + +### Parameters (shared) + +`jobSize` (~64–128 kB) · `peerSharingClosureByteLimit` (~1 MB) · `peerSharingLowWater`/`peerSharingHighWater` · +`requestTimeout` (generous, ≈ BlockFetch) · `frontSkew` (job-ordering bias, see §3 Job ordering) · +`L_hdr` (Leios header-diffusion window; `notifyPriority` tiers) · `stakeMaxActiveEbs` (~5) · +`peerSharingMaxActiveEbs` (~1–3) (per-peer active-EB cap). §5 (anticipated): `staggerPeers` (~1–2) · `staggerDelay` (~1–2 s). + +### Messages and stimuli + +**Wire messages.** The sender is not part of the message. + +- LeiosNotify: + - `MsgLeiosNotificationRequestNext` + - `MsgLeiosBlockAnnouncement(header)` + - `MsgLeiosBlockEquivocationProof(header₁?, header₂)` + - `MsgLeiosBlockOffer(ebHash)` / `MsgLeiosBlockTxsOffer(ebHash)` + - **[SF]** `MsgLeiosCertOffer(header)` +- LeiosFetch: + - `MsgLeiosBlockRequest(ebHash)` / `MsgLeiosBlock(ebHash, body)` + - `MsgLeiosBlockTxsRequest(ebHash, txs)` / `MsgLeiosBlockTxs(ebHash, txs)` + - **[SF]** `MsgLeiosCertRequest(headerHash)` / `MsgLeiosCert(cert)` +- ChainSync: + - `MsgRollForward(header)` merely echoed from ChainSync, not directly received by Leios logic + +`MsgLeiosBlockTxsRequest(ebHash, txs)` carries the requested job's tx hashes — +the `jobId` is the client's own handle and never goes on the wire — and the matching `MsgLeiosBlockTxs(ebHash, txs)` +carries those txs, paired to the outstanding `ReqJob` by FIFO order (§2). (TODO: since both ends already +hold `ebHash`'s body, they agree on `txset(ebHash)` and an ordering of it, so `MsgLeiosBlockTxsRequest`'s `txs` could be a compact +intset/bitfield over that index rather than full tx hashes.) + +**Stimuli**. + +- For received messages: `LevX(peer, …) = (peer, MsgLeiosX(…))` — the stimulus name is the wire name with the + `MsgLeios` prefix dropped (`LevBlock` ↔ `MsgLeiosBlock`). Except `LevRollForward`, which breaks the + mold. Its wire payload is `MsgRollForward(header)`, but the cert-bit case certifies the EB the *predecessor* + announced, which `header` alone does not identify. So the bridge enriches the stimulus with that EB's + identity — just the relevant parts (EB hash + election), from the preceding `HeaderState`: + `LevRollForward(peer, header, predEb)` (see §3). +- `LevCertValidated(headerHash, ebHash)` ChainSel validated a CertRB's cert (`headerHash` = the certified +announcement, `ebHash` = the EB it announced); peerless, deduped by election — at most +once per election; updates `LstCertified[el]`/`LstWanted[el]`) +- `LevPeerAdd(peer, class)` +- `LevPeerWindDown(peer)` +- `LevPeerRemove(peer)` +- `LevTimer(timeout, req)` +- `LevDiskDone(op)` +- `LevImmTipAdvanced(slot)` +- `LevSelfIssued(header, body)` an EB this node created, see `BEH-SelfIssued` +- (§5) `LevTimer(staggerDelay, req)`. + +**Actions**. +Outbound effects are inlined in the rules (no separate action vocabulary). Issuing a request = send the wire +request (`MsgLeiosBlockRequest` / `MsgLeiosBlockTxsRequest` / **[SF]** `MsgLeiosCertRequest`) to `peer` and +record the matching `Req…` in `LstPeerInflight[peer]`. Others: serve the response (`MsgLeiosBlock` / +`MsgLeiosBlockTxs` / **[SF]** `MsgLeiosCert`, the same message a client receives from upstream); relay a `MsgLeiosBlockAnnouncement` / `MsgLeiosBlockEquivocationProof` / **[SF]** `MsgLeiosCertOffer`; schedule +`dbWriteBody`/`dbWriteTxsIntoClosure`/**[SF]** `dbWriteCert`/`dbCopyFromTxCache`; `disconnectFrom(peer)`; schedule +`dbGarbageCollect`/`dbPromote`; set a timer; update state; emit closure-complete. + +--- + +## §3 Event → effect rules + +All updates within a rule are one atomic step. "consider fetching" = run the class-aware +LeiosFetch decision (below). `complete(el)` is an impure helper (not a stimulus), invoked synchronously by +`LevBlock`/`LevBlockTxs` once `el`'s body is present and no jobs remain: let `ebHash = LstWanted[el].ebHash`; +remove `el` from `LstWanted`; emit closure-complete; defer the disk-reading fan-out until the relevant +`LevDiskDone` (persist-before-expose) — once the write lands, that fan-out enqueues a closure offer into +`LstPeerNotifyQueue[d]` for each downstream `d` with `LstPeerOfferGates[d][el] = ebHash`. A request is only issued to `peer` if `LstPeerPresent[peer]` exists with `phase = Active`. Offers update +`LstPeerOfferings[peer][el]` (each `el ∈ electionOf[peer][ebHash]`) per the `These` state machine (§2): `LevBlockOffer`/`LevBlockTxsOffer` raise +the first-announced EB's `OfferSide`; `LevRollForward` records `CertSide` and `BodyAndClosure`. +(**[SF]** §6's `LevCertOffer` also writes `CertSide`.) + +### LeiosNotify rules + +- **`LevBlockAnnouncement(peer, header)`**: validate `header` (signature/KES, etc.; invalid ⇒ `disconnectFrom(peer)`), + and it must announce an EB (a LeiosNotify header that announces none is junk ⇒ `disconnectFrom(peer)`); + let `ebHash`/`bodySize`/`closureSize` be its fields, `el = election(header)`, `h` = its `HeaderHash`. Per-peer check on `LstPeerFirstAnnouncements[peer][el]` (LeiosNotify only; a ChainSync `LevRollForward` skips + it): absent → `One h`; `One h` (same) → duplicate ⇒ + `disconnectFrom(peer)`; `One h₁` (`h ≠ h₁`) → `Two h₁`; `Two _` (or any third distinct header) → + `disconnectFrom(peer)`. If accepted, note it to the TxCache (`txCacheNoteAnnouncement(ebHash)`, §7) and update central `LstFirstAnnouncements[el]`: absent → `One header`, and if `ebHash` is not complete nor below the immutable tip + `LstWanted[el] = AwaitingBody{ ebHash, bodySize, closureSize }`, then enqueue the + announcement into every downstream `LstPeerNotifyQueue` and consider fetching; `One` → `Two` (different + header) → record the equivocation, enqueue the equivocation proof downstream (**[SF]** §6 + suppresses this once the election is certified); already `Two` → nothing further. An equivocating + `ebHash` is never wanted (**[SF]** until/unless certified, §6). + +- **`LevBlockEquivocationProof(peer, header₁?, header₂)`** (equivocation proof; `header₂` always, `header₁` only if `peer` had not + already sent us the first; `ebHashᵢ`/`hᵢ` are each header's EB / `HeaderHash`): validate it is a genuine + equivocation — both headers validly signed (signature/KES, etc.), each announcing an EB, for the same + election with `h₁ ≠ h₂` (using `header₁` if present else our recorded first + `LstPeerFirstAnnouncements[peer][el] = One h₁`; if neither, or if a header announces no EB, `disconnectFrom(peer)`). Advance `LstPeerFirstAnnouncements[peer][el]` to `Two` (inconsistent / already-`Two` + with other headers → `disconnectFrom(peer)`). If `LstFirstAnnouncements[el]` is not yet `Two`, record the + equivocation and enqueue the proof downstream (**[SF]** §6 suppresses this once the election is certified). + If it was absent the proof carries `header₁` (else validation above disconnected): set `Two h₁ h₂` (left `h₁` = + `ebHash₁`, the older, first-announced winner) and make `ebHash₁` wanted just as `LevBlockAnnouncement`'s `One` branch — gated + on `ebHash₁` being neither complete nor below the immutable tip. If it was `One h₁`, `ebHash₁` is already the + recorded, wanted first; just advance to `Two`. The equivocating `ebHash₂` is never wanted. + +- **`LevBlockOffer(peer, ebHash)`** (LeiosNotify): `ebHash` must be one `peer` (first-)announced — i.e. `electionOf[peer][ebHash]` + is non-empty (anything else, e.g. an EB `peer` only relayed as an equivocation, ⇒ `disconnectFrom(peer)`). + Raise the `OfferSide` to at least `Body` in `LstPeerOfferings[peer][el]` for each `el ∈ electionOf[peer][ebHash]`. + Consider fetching if `ebHash` is wanted. No `LstWanted` creation, no size. (**[SF]** §6 also admits `peer`'s cert-asserted EB and its precedence + over the first-announced.) + +- **`LevBlockTxsOffer(peer, ebHash)`** (LeiosNotify; implies a body offer): same `electionOf[peer][ebHash]` check; set + `OfferSide = BodyAndClosure` at each such `el`. Consider fetching if `ebHash` is wanted. + +- **`LevRollForward(peer, header, predEb)`** (ChainSync): if `header` announces an EB `ebHash` (unlike + LeiosNotify, a non-announcing chain header is a normal block — no disconnect, just no announcement effect), + update + the central `LstFirstAnnouncements[election(header)]` exactly as `LevBlockAnnouncement`'s central branch (set `LstWanted`, + relay, detect equivocation) — but never `LstPeerFirstAnnouncements` (chain relay is exempt from the per-peer ≤2 + bound). This holds regardless of the cert bit. If the cert bit is set, the RB's body certifies the + earlier EB `ebHash′` that its predecessor announced — given by `predEb`, the predecessor's announced-EB identity + (its `HeaderHash` `headerHash′`, EB hash `ebHash′`, and election `el′`) from the preceding `HeaderState`, which the wire `MsgRollForward(header)` does not + carry (hence the enriched stimulus, §2): + record `peer`'s body+closure offer of `ebHash′` in `LstPeerOfferings[peer][el′]` + (`These (Cert headerHash′ ebHash′ _) BodyAndClosure`, latest wins). ChainSel validates that cert and emits `LevCertValidated(headerHash′, ebHash′)`. + Cert-conflict disconnect: if `LstCertified[el′]` is already set with a `HeaderHash` other than `headerHash′`, + this peer is offering a cert that cannot exist ⇒ `disconnectFrom(peer)`. + Consider fetching. (**[SF]** §6: `ebHash′`'s offer takes precedence over a LeiosNotify offer for the + first-announced; the recorded `CertSide` also drives `BEH-CertFetch` — request the cert from that peer when we + lack it, subject to the preferable-header suppression TODO there; and the cert-conflict disconnect above + extends to the `LevCertOffer` vehicle.) + +- **`LevNotificationRequestNext(peer)`**: raises `LstPeerNotifyQueue[peer]`'s capacity by one; if non-empty, dequeue + the highest-priority notification (`notifyPriority`) and send it. Sending an announcement for `ebHash` + opens its gate (`LstPeerOfferGates[peer][el] := ebHash`), then consider offering that EB to `peer` if its + artifact is stored. (**[SF]** §6: sending a `MsgLeiosCertOffer` pivots `peer`'s gate — drop the superseded announced EB for that election from `LstPeerOfferGates[peer]`, add the certified EB.) + +### LeiosFetch rules + +**Decision** (class-aware; offer-triggered, not a global budget sweep). **A peer's request set is a +function of that peer's own state alone** — its offers (`offerersBody`/`offerersClosure` restricted +to `peer`), its in-flight `LstPeerInflight[peer]`, and its class — plus the shared want-state +(`LstWanted`/`LstCertified`). It never reads another peer's per-peer state, so the per-peer decision +loops are mutually independent (embarrassingly parallel). Exactly two couplings to cross-peer state +exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggered requesting. + +- Per-peer active-EB cap (all classes; the bound on how many distinct EBs a peer fetches at once). + Among `peer`'s offered-and-wanted EBs, the *admitted* ones are every EB already active for `peer` + (some `Req _ ebHash _ ∈ LstPeerInflight[peer]`) plus — taking the rest in `BEH-FetchPriority` order + (§1: certified FreshestLast ahead of uncertified FreshestFirst) — as many not-yet-active EBs as keep + `activeEbs(peer) ≤ maxActiveEbs[class]` (`stakeMaxActiveEbs` for stake-sampled, `peerSharingMaxActiveEbs` + for peer-sharing; separate per class, never conflated). The issue-rules below fire only for admitted EBs. + This caps the number of distinct EBs in flight per peer — per-EB multiplicity stays uncapped — so a burst + of announcements, or a peer answering only as slowly as `BEH-Timeout` permits, accrues at most + `maxActiveEbs[class]` EBs' worth of outstanding requests from that peer rather than one per announcement. + Reads only `LstPeerInflight[peer]`, so it is not a cross-peer coupling. +- Body (any class) — for each wanted election with `LstWanted[el] = AwaitingBody{ ebHash, … }` that `peer` + offers (`peer ∈ offerersBody(ebHash)`): issue `ReqBody el ebHash` to `peer` unless `(peer, ReqBody el ebHash) ∈ + LstPeerInflight[peer]`. No per-EB multiplicity cap and no cross-peer check — every offerer is asked + independently (the active-EB cap above bounds the distinct EBs per peer, not the offerers per EB). +- Stake closure — for a `StakeSampled` `peer ∈ offerersClosure(ebHash)` with `LstWanted[el] = AwaitingTxs`: + issue `ReqJob el ebHash j` to `peer` for each still-outstanding job `j ∈ LstWanted[el].jobs` with + `(peer, ReqJob el ebHash j) ∉ LstPeerInflight[peer]`. No per-EB job cap. Its only shared input is `LstWanted[el].jobs` + (which any peer's response shrinks) — central want-state, not another peer's state. +- PeerShare closure — for a `PeerSharingSampled` `peer ∈ offerersClosure(ebHash)`: while + `peerSharingInFlightBytes(peer, ebHash) < peerSharingClosureByteLimit`, pick a still-outstanding job not already in-flight + to `peer` minimizing `jobInflightPeers(ebHash, j)` — rarest-first, the one standing exception: it reads + how many *other* peers each job is in-flight with — ties broken by the random front-skewed order + (Job-ordering step below). Issue `ReqJob el ebHash j` to `peer`; stop at the limit; responses refill within a low/high-water + band. +- Job ordering — every job selection uses the same random order, slightly skewed toward lower-index + (front-of-EB) jobs (`frontSkew`): the randomness avoids cross-peer head-of-line waiting, and the front-skew + makes a growing contiguous prefix arrive well before the last job. +- (§5, not yet) Staggered requesting adds the second cross-peer coupling — while an EB is young, hold + each of its items to ≤ `staggerPeers` peers (again reading cross-peer in-flight). + +- **`LevBlock(peer, ebHash, body)`**: the front of `LstPeerInflight[peer]` must be `ReqBody _ ebHash` (§2; drop if not); let `el` + be its election. Validate hash = `ebHash` and actual size against `ebHash`'s announced `bodySize` (from + the request, not `LstWanted`); on mismatch drop (adversarial). Else, if `LstWanted[el]` still wants `ebHash`: `scheduleDisk dbWriteBody`, then `BEH-ChunkJobs` — `txCacheOnBody` + (§7) hits and Mempool hits (`mempoolQueryPresent`) are copied in (`dbCopyFromTxCache` / `txCacheOnAcquire`), + the rest → jobs — set `LstWanted[el] = AwaitingTxs{ ebHash, jobs }`, + and if no jobs → `complete(el)`. Otherwise the want has moved on (cert switch / tip advance) — drop + the result, no disconnect. Consider fetching. + +- **`LevBlockTxs(peer, ebHash, txs)`**: the front of `LstPeerInflight[peer]` must be a `ReqJob _ ebHash jobId` for `ebHash` + — the `jobId` is recovered from that front entry, not the wire (§2; drop if not); let `el` be its election. Validate against the request; on mismatch drop. Else: `scheduleDisk dbWriteTxsIntoClosure`; offer the txs to the TxCache (`txCacheOnAcquire`, §7). + If `LstWanted[el]` still wants `ebHash`, remove `jobId` from its outstanding jobs (only `el` + advances; if now empty → `complete(el)`); otherwise the want has moved on — drop, no disconnect. + Consider fetching (PeerSharing peers refill toward `peerSharingHighWater`). + +- **`LevCertValidated(headerHash, ebHash)`** (the cert for announcement `headerHash`, which announced `ebHash`, has been validated — by ChainSel on a CertRB, or + **[SF]** by `BEH-CertFetch`; emitted only post-validation, so reliable (§6 covers ChainSel's tentative-header timing); `el` = + the announcement's election; **peerless** — the cert is cryptographic — and deduped by election, so it fires at + most once per election): set `LstCertified[el] = (headerHash, ebHash)` (`BEH-FetchPriority` now ranks `ebHash` top) and + ensure `LstWanted[el]` wants `ebHash` — but, exactly as `LevBlockAnnouncement`, only when `ebHash` is neither complete + (consult the store via `dbQueryPresent`, as `BEH-Startup` does) nor below the immutable tip, since the cert routinely + validates after we already fetched and completed the first-announced EB; if so, add an `AwaitingBody` + entry when absent (sizes from its announcement). Consider fetching. (**[SF]** §6: when `ebHash` *differs* from + the first-seen EB `LstWanted[el]` was tracking, switch `LstWanted[el]` to `ebHash` in place — applying the + same completeness check (we may already hold it, e.g. self-issued via `BEH-SelfIssued`): complete ⇒ drop the + entry, body present ⇒ `AwaitingTxs`, else `AwaitingBody`; the first-seen's in-flight reqs are left to the + response-guard / `BEH-Timeout`. Also, if `LstAnnouncedCert[el]` is unset, set it to `ebHash` and enqueue a + `MsgLeiosCertOffer` for `ebHash` into every downstream peer's `LstPeerNotifyQueue` (the cert relay, deduped via + `LstAnnouncedCert`); and disconnect any peer whose `LstPeerOfferings[_][el]` `CertSide` names a different `HeaderHash`.) + +- **`LevBlockRequest(peer, ebHash)` / `LevBlockTxsRequest(peer, ebHash, txs)`** (server): if `dbQueryPresent` confirms the store + has the requested body / txs, serve it; otherwise `disconnectFrom(peer)`. (**[SF]** §6 adds `LevCertRequest`.) + +### Everything-else rules + +- **`LevPeerAdd(peer, class)`**: `LstPeerPresent[peer] = { class, Active }`; `LstPeerOfferings[peer] = ∅`. + +- **`LevPeerWindDown(peer)`**: `LstPeerPresent[peer].phase = WindingDown`. Where `peer` is upstream, issue it no new requests; + where `peer` is downstream, stop feeding `LstPeerNotifyQueue[peer]`. Outstanding `LstPeerInflight[peer]` stay until answered + or `BEH-Timeout`. Consider fetching (re-route what `peer` won't deliver to other peers). + +- **`LevPeerRemove(peer)`**: `LstPeerPresent \= {peer}`; drop + `LstPeerFirstAnnouncements[peer]`/`LstPeerOfferings[peer]`/`LstPeerOfferGates[peer]`/`LstPeerNotifyQueue[peer]`/`LstPeerInflight[peer]`. + The connection is gone, so no further message from `peer` can arrive. Consider fetching. + +- **`LevTimer(timeout, req)`**: `req` is overdue → `disconnectFrom(peer)` for the peer that owns it. + +- **`LevDiskDone(op)`**: mark the bytes stored (now readable); release fan-out deferred on `op`. + +- **`LevImmTipAdvanced(s)`**: `scheduleDisk dbGarbageCollect(s)`/`dbPromote`; range-delete every slot-indexed state variable + below `s` (`BEH-TipAdvance`) — the `Election`-keyed + `LstFirstAnnouncements`/`LstPeerFirstAnnouncements`/`LstPeerOfferings`/`LstPeerOfferGates`/`LstWanted`/`LstCertified` (**[SF]** §6's `LstAnnouncedCert`). + The TxCache is not pruned here (its own window/age eviction, §7) and `LstPeerInflight` is not GC'd here. Consider fetching. + +- **`LevSelfIssued(header, body)`** (peerless; `BEH-SelfIssued`): treat `header` as a first announcement — + run `LevBlockAnnouncement`'s central-branch update (record `LstFirstAnnouncements[el]`, make wanted, relay + downstream, `txCacheNoteAnnouncement`), but no per-peer state and no wire-validation (there is no peer, and + we built the header), exactly as `LevRollForward` skips `LstPeerFirstAnnouncements`. Then run `BEH-ChunkJobs` + on `body` directly — no in-flight `Req` to match, we already hold it: the Mempool holds the txs we built the + EB from (modulo a churn race), so the closure is acquired via `mempoolQueryPresent`/`txCacheOnAcquire` and + `complete(el)` fires with no fetch. Consider fetching (for any txs the race left un-acquired). + +--- + +## §4 Expected properties + +(Safety = invariant at every trace state; Liveness = eventually, with fairness.) + +### LeiosNotify + +- Want is announcement-gated (safety). `dom(LstWanted) ⊆ dom(LstFirstAnnouncements) ∪ dom(LstCertified)`, and for + each `el ∈ dom(LstWanted)`, `LstWanted[el].ebHash` is the first-announced EB for `el` (**[SF]** or `LstCertified[el]`'s `EbHash`); one + wanted EB per election is structural (the key). An equivocating EB is never wanted/fetched/served + **[SF]** unless it is the certified one. +- Offers are announced or certified (safety). The EB offered by `peer` (the `CertSide` EB if present, + else first-announced) is the first EB `peer` announced for its election **[SF]** or `peer`'s + cert-asserted EB — judged per peer against `LstPeerFirstAnnouncements[peer][el]` / `LstPeerOfferings[peer][el]`'s `CertSide`, + not the global `LstFirstAnnouncements`. Anything else triggered `disconnectFrom`. +- Offers are bounded (safety). `∀ peer, el`: `LstPeerOfferings[peer][el]` holds at most one cert claim (`HeaderHash`) and one + offer level; a peer churning headers cannot accumulate more. +- Announce-before-offer (safety). We never send a downstream peer an offer for an EB unless it + is in that peer's `LstPeerOfferGates`. +- Bounded announcements (safety). Per upstream peer and election: ≤2 uncertified announcements + (`LstPeerFirstAnnouncements[_][el]`); **[SF]** and `LstPeerOfferings[_][el]`'s `CertSide` holds ≤1 cert claim (`HeaderHash`) + across both cert-assertion vehicles (one-shot `LevCertOffer`, repeatable `LevRollForward`); a + second `LevCertOffer` or a different `HeaderHash` disconnects. + +### LeiosFetch + +- Cert uniqueness (safety). At most one EB per election is certified, and a peer claiming a cert for a + different `HeaderHash` than the certified announcement is disconnected — baseline on the cert-bearing + `LevRollForward` path; **[SF]** §6 extends the same check to the `LevCertOffer` vehicle. +- Client soundness (safety). Each in-flight `ReqBody`/`ReqJob`/**[SF]** `ReqCert` was issued to a peer + offering that `ebHash`/job/cert, for an `ebHash` wanted at issue time. A request may outlive + its want (its response is then dropped, §3), so it is reclaimed by a + matching response or by `LevPeerRemove` (which a `BEH-Timeout` triggers) rather than held invariant against current `LstWanted`. +- Server soundness (safety). The node serves a downstream request only for data stored (readable); + a request for absent data triggers `disconnectFrom`. +- TODO (Server-vs-Client soundness race). We offer `peer` an EB; `peer` honestly requests it (its own Client + soundness); but if we GC the artifact in between — e.g. it fell below our immutable tip and was dropped + rather than promoted — the request finds it absent and we disconnect an honest `peer` (and symmetrically a + peer can disconnect us). Diffusing it needs a GC grace window: offered content stays readable for at least + the offer→request latency past when it would otherwise be dropped, so the disconnect fires only on a genuine + misbehaver. The exact delay — and whether a delay alone suffices vs. refcounting offered content — is unsettled. +- Sizes and hashes match the announcement (safety). Every body/closure fetched or served matches both its + announced size and its content hash — a body hashes to its announced `ebHash`, a job's txs match the + requested job — and any mismatch is rejected (adversarial). +- PeerShare closure cap (safety). `∀ peer : PeerSharing peer, ebHash: peerSharingInFlightBytes(peer, ebHash) ≤ peerSharingClosureByteLimit`. +- Per-peer active-EB cap (safety). `∀ peer: activeEbs(peer) ≤ maxActiveEbs[class(peer)]` (per class, never conflated). +- In-flight integrity (safety). Across the disconnect/response/timeout races — a response and a + `BEH-Timeout`/`disconnectFrom` landing on the same request, or a response arriving after its peer was + removed — every issued request leaves `LstPeerInflight` exactly once: never double-removed, never leaked. + The reference model cannot actually reach this hazard (stimuli are handled atomically and `LstPeerInflight` + is the sole source of truth, so a redundant removal is a no-op and any straggler is reclaimed by + `LevPeerRemove`); we state it anyway because the model is a conformance oracle for a concurrent + implementation whose threads do interleave these, and because any derived mirror of in-flight — per-peer + and global byte budgets (Σ in-flight sizes), reverse request indexes — desyncs under a double-remove or a + leak. So it is the invariant incrementalization and the real node must preserve, not one the atomic core + can currently violate. +- No wasted re-request (safety). No in-flight request targets an already-complete EB/received job **[SF]** or already-validated cert. +- Persist-before-expose (safety). Anything offered/handed-off is already stored (readable) — within a run + and across a clean restart. (Resume-from-suspend can still race a reader against a GC deleter; robustly + closing that gap needs content pinning — the deferred TODO of §7.) +- Progress (liveness). Wanted data persistently offered by an honest present peer is eventually + fetched; order is certified (FreshestLast) ahead of uncertified (FreshestFirst). +- Completion (liveness). Once body+all-txs present, completion is detected and (after the write lands) offered to all consumers (a.k.a. fanned-out). + +### Everything else + +- Adversary-tolerance (liveness). Withholding/equivocating/lying peers cannot prevent acquisition + from an honest offerer; the generous timeout disconnects dead peers, reclaiming their slots (not a security mechanism). + +--- + +## §5 Anticipated refinements (roadmap) + +- **Staggered requesting** (hold-off before broadening). Soften the "immediately request from + every offerer" aggressiveness: while an EB is younger than `staggerDelay` (~1–2 s) measured + from its own slot-time (not from when we received offers or issued requests), keep each item + (body/job) in-flight with at most `staggerPeers` (~1–2) peers; once the EB ages past that, + pull the item from all other offerers of its closure. Clocking on EB age rather than message + timing makes the window objective and un-gameable. (Consequence: an EB we first learn of + already older than `staggerDelay` gets no hold-off — pulled from everyone at once, right for a + laggard.) Per-class counts, never conflated. Clock = the EB slot (the `LstWanted` election key); + multiplicity = `jobInflightPeers`/per-class variants; needs no per-request issue-time. +- **Limit stale EBs within the active-EB cap.** The per-peer active-EB cap (§3) currently treats all EBs + alike. It could additionally refuse to admit a new not-yet-active EB when that EB is already "too old" and + the peer's active set already holds at least one "too old" EB — so a peer works on at most one stale EB at a + time, keeping its slots for fresher EBs we can still vote on. ("Too old" threshold TBD — e.g. past the + freshness window the `notifyPriority` tiers already use.) +- **Shrink jobs as their txs arrive by other means.** A job's tx-set is fixed at chunk time, so a request for + it (to another offerer, or a re-issue) asks for the whole set even after some of its txs have arrived — via + a concurrent job (for another EB), a Mempool insert, or a TxCache hit — and those redundant bytes are + received and deduped (sound, just wasteful bandwidth). Refinement: shrink the outstanding job to drop the + already-acquired txs, so subsequent requests for it exclude them. Partial redundancy only ever trims future + requests this way: we never cancel an already-sent request just to re-issue a smaller version of the same + job (churn for no gain, and remote cancels are unreliable anyway — they race the response already in flight). + A cancel is reserved for total redundancy — the next item. +- **Best-effort job cancellation (only once a job is wholly redundant).** Once a job is entirely in hand — its + `MsgLeiosBlockTxs` arrived, or all its txs were acquired by other means — other peers still holding that same job + in flight have nothing left to give. (We ask several at once, aggressive / rarest-first, mostly stake-sampled, + so this is common.) Send each a best-effort `MsgTryCancel` for it (perhaps only stake-sampled peers, the ones + we ask aggressively — TBD). We never assume a cancel succeeds: the peer is still obligated to send the matching + response to the original `MsgLeiosBlockTxsRequest`, and nothing ever responds to the `MsgTryCancel` itself — but with a + cancel outstanding we now also accept an entirely empty `MsgLeiosBlockTxs`, which is how a peer that honored the + cancel discharges that obligation. Saves the redundant transfer when honored, costs only the cancel message + when not. +- **Chunk the EB body (Merkle-rooted segments).** `BEH-BodyFetch` currently pulls the whole body from a + single offerer (and redundantly from each). Instead, split the body into objectively-agreed segments — + e.g. fixed `bodyJobsSize` (~64 kB) spans of its canonical serialization — and let the body's announced hash + (what `ebHash` commits to) be a Merkle root over them. Each segment then carries a Merkle path, is verifiable + on its own, and can be fetched from a different offerer in parallel: the body analogue of chunking txs into + jobs, needing no FEC. (FEC over the segments would be a further elaboration — any sufficient subset + reconstructs, so a slow or missing peer costs only its parts. New parameter `bodyJobsSize`.) +- **Chunk the closure incrementally (incremental offers for streaming closures).** The closure is already split into jobs, but a peer + offers it all-or-nothing: `BodyAndClosure` advertises the complete closure, so a peer can only offer once it + holds every tx. Independently of whether the body is chunked, a peer could offer the closure incrementally — + advertising the first chunk as soon as it has it, even while later chunks are still missing, so we can start + fetching what is available immediately. This needs only that `MsgLeiosBlockTxsOffer` carry one extra small + field saying which chunks the offer covers: a count of leading chunks held, or a short bitfield with one bit + per chunk. +- **Resist a protocol storm.** Bad luck can put very many EBs in flight at once — far more closure to diffuse + than the network handles comfortably. The hazard is that voting certifies an EB whose closure honest nodes + could not diffuse well enough to hold, leaving a certified EB the network cannot actually select. TODO: read + the recent proposal for how to prevent this scenario. + +--- + +## §6 Skew fallback + +Under the baseline (§1–§4) the certified EB for an election is the one every honest node saw +announced first, so none of this fires. It exists for the rare timing/network failure where +the certified EB differs from a node's first-seen, and for the LeiosNotify cert-gossip path that +diffuses a cert independently of the chain. §6 only *adds* — one state variable (`LstAnnouncedCert`), the three +cert messages with their stimuli, behaviors, and rules. Its extensions to existing main-spec rules are not +repeated here: they live inline at those rules, tagged **[SF]**. §6 redefines no main-spec state type. All of +it is **[SF]**. + +§6 presumes ChainSel validates a CertRB's cert before tentatively forwarding that CertRB's header downstream — +diffusion pipelining would otherwise forward the header ahead of body validation. That is what stops us from +causing a downstream peer to process a cert-bit `LevRollForward` before we ourselves have validated the cert. +The cost is a small per-CertRB delay to that tentative-header forward, not a headers-first concession: the +CertRB's body is already in hand at processing, so it merely reorders the validation work. (Acting on a cert — +setting `LstCertified`, switching `LstWanted`, offering it downstream — is gated separately on +`LevCertValidated`, i.e. on our own validation, independent of this timing.) + +### Added state + +- `LstAnnouncedCert : Election ↦ EbHash` — the validated cert we have offered downstream peers + for the election. The cert analogue of `LstFirstAnnouncements`, driving and deduping the `MsgLeiosCertOffer` relay. +- The `CertNotificationSeen` flag on `LstPeerOfferings`'s `CertSide` (§2) is set here — by `LevCertOffer`, + never by `LevRollForward` — recording the cert-assertion vehicle. The main spec leaves it unset. +- `dbWriteCert` — a validated cert is written to the disk store (keyed by `HeaderHash`), whence it is read to + serve a `LevCertRequest` or to apply late. + +Cert identity is the announcement `HeaderHash`, not the `EbHash`: a cert binds to an *announcement*. So +`MsgLeiosCertRequest`/`ReqCert` key by `HeaderHash`, `CertSide = Cert HeaderHash EbHash CertNotificationSeen` +carries both the claimed announcement (for `BEH-CertFetch`) and the offered `EbHash`, and `predEb` carries the +predecessor's `HeaderHash`. Validation needs only the `HeaderHash` (the identity the votes commit to) plus the +election's committee, and the want/priority effect needs the `EbHash`+`Election` — so nothing relies on +retaining the full header, and the certified `HeaderHash → cert` lives in the disk store post-validation. +`LstCertified` pairs the certified `HeaderHash` with its `EbHash` (`Election ↦ (HeaderHash, EbHash)`) so a +conflicting cert claim can be rejected at offer time (§3/§6); `LstAnnouncedCert` stays `Election ↦ EbHash` +(relay-dedup). + +### Added events + +- Messages: `MsgLeiosCertOffer(header)`, `MsgLeiosCert(cert)`, `MsgLeiosCertRequest(headerHash)` +- And the corresponding `Lev*` stimuli. + +### Behaviors + +- **`BEH-CertNotify`**. `LevCertOffer(peer, header)` carries an `RbHeader`, read as both an + announcement of its EB `ebHash` (so it can be the first announcement we see; sizes usable like any + `LevBlockAnnouncement`; exempt from the ≤2 uncertified-announcement bound) and an offer of that EB's specific + cert. At most one `LevCertOffer` per `(peer, election)`: a second naming a different `HeaderHash` is a peer + claiming two certs for one election — impossible, so disconnect `peer`. Likewise, if we already hold a + validated cert for the election (`LstCertified[el]`) whose `HeaderHash` differs from the one offered, this + offer asserts a non-existent cert — the cert-conflict disconnect (§3) applied to the `LevCertOffer` vehicle. + On receipt we record + `peer`'s cert assertion in `LstPeerOfferings`'s `CertSide` (its EB and the `CertNotificationSeen` flag), and the + peer must stop sending vote notifications (which are otherwise out of this document's scope) for `ebHash`. A `LevCertOffer` offers the cert, not + body/closure — those still come via `LevBlockOffer`/`LevBlockTxsOffer`. If we don't already hold the + validated cert, fetch it (`BEH-CertFetch`) aggressively — every offerer, no multiplicity cap — to + resist slow-loris stalling, as for body/job fetch. + +- **`BEH-CertFetch`**. When any peer has offered a cert and we lack + the validated cert, request it from that peer (`MsgLeiosCertRequest(headerHash)`, recording `ReqCert el headerHash`) aggressively (every offerer, no + multiplicity cap, `BEH-Timeout` for dead peers). On the response, validate. Invalid → disconnect + only the provider. Valid → emit `LevCertValidated(headerHash, ebHash)` (its full §3 effect — including the + **[SF]** skew extension — then applies). ChainSel, on first processing a CertRB (its header diffused by ChainSync, its body by + BlockFetch), is the other emitter of `LevCertValidated` + (§1). TODO: while a cert-bearing `LevRollForward`'s header is still preferable to our current selection, + BlockFetch is already fetching that CertRB body (which carries the cert), so the + redundant `MsgLeiosCertRequest` to that peer could be suppressed until the header is no longer preferable. + Conversely, when we do fetch the cert over LeiosFetch first, we could paste that header and the `LevCert` + cert together into the CertRB and hand it to the ChainDB, so BlockFetch stops trying to acquire it. + +- **Cert-serving** (`BEH-FetchServe` extension). A downstream `LevCertRequest(peer, headerHash)` is served from + the store if present, else `disconnectFrom(peer)` — exactly as for bodies/closures. + +### Rules + +- **`LevCertOffer(peer, header)`** (`ebHash` = header's EB, `headerHash` = its `HeaderHash`, `el = election(header)`): treat the header as an + announcement (run the `LevBlockAnnouncement` update; exempt from the ≤2 bound). If `LstCertified[el]` is + already set with a `HeaderHash` ≠ `headerHash` ⇒ `disconnectFrom(peer)` (offering a cert that cannot exist — + the §3 cert-conflict disconnect). Update `LstPeerOfferings[peer][el]`'s + `CertSide`: if it already has `CertNotificationSeen` set ⇒ `disconnectFrom(peer)` (a second `LevCertOffer`); + if it is `Cert headerHash′ _ _` with `headerHash′ ≠ headerHash` ⇒ `disconnectFrom(peer)`; if `Cert headerHash _ _` (same) → set + `CertNotificationSeen`, keeping the `OfferSide`; if there is no `CertSide` → set it to `Cert headerHash ebHash` with + `CertNotificationSeen`, dropping any `OfferSide` (the prior body/closure were for the first-announced, + a different EB). A `LevCertOffer` offers the cert, not body/closure — those still come via + `LevBlockOffer`/`LevBlockTxsOffer` for the certified EB. If we lack the validated cert, fetch it + (`BEH-CertFetch`) aggressively. `peer` must also stop sending vote notifications for `ebHash`. + +- **`LevCert(peer, cert)`**: validate `cert` against the `headerHash` of the `MsgLeiosCertRequest(headerHash)` it + answers — the front `ReqCert` of `LstPeerInflight[peer]` (§2; drop if the front isn't a `ReqCert`) — plus the + election committee. Invalid → `disconnectFrom(peer)`. Valid → `scheduleDisk dbWriteCert`, emit `LevCertValidated(headerHash, ebHash)` + (`ebHash` = the EB that announcement announced). + +- **`LevCertRequest(peer, headerHash)`**: if `dbQueryPresent` confirms the store holds the cert for + `headerHash`, serve it (`MsgLeiosCert`); otherwise `disconnectFrom(peer)` — the cert analogue of §3's + body/closure server rule, realizing the `Cert-serving` behavior above. + +### Properties + +The **[SF]**-tagged clauses in §4 belong here: the cert-conflict disconnect extended to the `LevCertOffer` +vehicle (the `LevRollForward` case is baseline, §3); want/offers admitting the certified EB; and +`LstPeerOfferings[_][el]`'s `CertSide` holding ≤1 distinct cert claim (`HeaderHash`) across both vehicles +(one-shot `LevCertOffer`, repeatable `LevRollForward`). + +## §7 TxCache (bounded cross-EB tx dedup) + +The TxCache lets `BEH-ChunkJobs` skip re-fetching a tx we already hold because a recent EB referenced it. It is +load-bearing for throughput, not optional: without it a node re-fetches shared txs per-EB, and under +adversarial conditions (e.g. a mempool-fragmentation attack, where pools' EBs share few txs with a node's +mempool) that redundancy can drive Leios throughput toward zero. Its contract, though, is small and stable, +which is what lets the machinery below be skipped by some readers: +- **Sound**: a reported hit is a tx we genuinely hold (`acquired ⟺ bytes present`, maintained by + construction below) — a false hit would make `BEH-ChunkJobs` skip a needed fetch and stall the closure. +- **Recall**: bounded by a space–time trade-off — we dedup only recent reuse, within the window below, to + bound the cache's memory and disk; a tx referenced beyond the window, not yet acquired, or from a + non-qualifying EB is re-fetched, trading some bandwidth for bounded space. + +So some readers can treat the cache as that black box — sound membership, recall bounded to recent reuse — and +skip §7's bounding/eviction/persistence machinery; it's the machinery that's separable from the protocol, not +the cache. It is a component separate from the LeiosDB closure store (LeiosDB keeps EBs until immutability; the +TxCache keeps a far tighter recent window), so the two are GC'd independently. + +The main spec touches it only through these hooks: + +- **`txCacheNoteAnnouncement(eb)`** — `LevBlockAnnouncement` calls this for every accepted announcement; the cache + applies its own qualifying filter (below) and advances its window. +- **`txCacheOnBody(eb, txset(eb)) → hits`** — `BEH-ChunkJobs` calls this when the body arrives; it returns the + cached (already acquired) txs so they're not re-fetched, and records that `eb` references `txset(eb)`. +- **`txCacheOnAcquire(txs)`** — called when some txs' bytes arrive (`LevBlockTxs`, or a Mempool hit); for each + tx the cache is still tracking (`refcount > 0` — some eligible in-window EB references it) it marks + `acquired` and stores the bytes; a tx no eligible in-window EB references is ignored (not stored). +- **`dbCopyFromTxCache(txs)`** — copy hit bytes from the cache's backing store into the requesting EB's + LeiosDB closure. + +Eviction/GC is internal (announcement- and time-driven); the only place the body sequences it is `BEH-Startup`. + +**Hot-path constraint.** The dedup lookup sits in a hot loop — `BEH-ChunkJobs` consults the cache once per tx of +every arriving EB body, up to ~15000 lookups per body, and bodies arrive continuously — so its per-lookup +latency is as much a design driver as soundness and bounded memory. Each lookup must be a single O(1) read of +one in-memory hash table (`LstTxCacheIndex`), taking `acquired` directly; the design deliberately keeps no +second index (no slot-keyed structure, no reverse `tx → {EB}` index — eviction instead re-reads the one leaving +body, below), since consulting multiple structures per lookup, or any scan, would not keep up. + +**State.** Two in-memory variables, plus a disk-resident backing store: +- `LstTxCacheIndex : TxHash ↦ { refcount, acquired }` — the membership/refcount index, the one large structure + (~`128` EBs × up to ~15k txs ≈ 2 million entries). `refcount` = how many in-window qualifying EBs + whose body we hold reference the tx; `acquired` = its bytes are in the backing store. Dedup hits are read + from `acquired`, never `refcount`. +- `LstTxCacheWindow : Election ↦ { ebHash, foldedIn }` — the `≤128` qualifying announcements, kept slot-ordered + (the `Election`'s slot gives both the ordering — pop-min for eviction — and the age). `foldedIn` records + whether we've folded that EB's body into the refcounts, so eviction knows whether to decrement. +- The backing store (on disk, not an `Lst*` in-memory variable): a separate, content-addressed store of the + acquired bytes, read/deleted by `TxHash` (`dbCopyFromTxCache`/`dbTxCacheEvict`). Its storage mechanism is + deliberately unspecified; the one requirement is that its own memory use stays bounded — in particular it + must not keep a full second in-memory `TxHash → location` index alongside `LstTxCacheIndex`. + +**Qualifying predicate** (what `txCacheNoteAnnouncement` admits): the announcement is the first we saw for +its election — honest EBs are never equivocated, so the first-seen is the honest EB and certs are +irrelevant here (`LevCertValidated` is ignored) — and it arrived ≤ `30s` after its slot, which stops +an adversary from withholding then bursting stale announcements to reshape the cache. + +**Window.** The youngest `128` qualifying announcements by slot. Announcement-driven and body-free: a +young body-less announcement still takes a slot and advances the cutoff — which is why the cache reacts to +announcements even when bodies never arrive. + +**Refcount lifecycle.** Increments happen only at body arrival, the only moment the txlist is known (an +announcement is a header; an acquisition is one tx's bytes): `txCacheOnBody` does `++refcount` for each tx of +an in-window EB and marks it folded-in. `acquired` is then set by `txCacheOnAcquire`, but only for a tracked +tx (`refcount > 0`) — so `acquired ⟹ refcount > 0`, and bytes for a tx no eligible EB references are dropped, +not stored. Because the hit-set is read from `acquired`, an EB's own freshly-referenced-but-unfetched txs +correctly miss and get fetched. + +**Eviction** — two triggers, both a pop-min from the slot-ordered window (index-accelerated, never a scan): +- the window exceeds `128` (a younger qualifying announcement arrived), or +- the oldest EB's age exceeds `txCacheMaxAge` (time/slot-driven, so it fires even when no announcements arrive). + +The action: take the leaving EB; if its body was folded in, re-read that one body, `--refcount` each tx, and +at 0 remove the entry and `dbTxCacheEvict` the bytes (if acquired). A body-less leaving EB folded nothing, so +there is nothing to undo. Eviction is prompt and physical, so the backing-store footprint stays ≈ the +window rather than ballooning to LeiosDB's volatile size. + +The age trigger is essential, not redundant: if the network stops issuing EBs the count trigger never fires +and the EB never leaves — yet the immutable tip keeps advancing and LeiosDB GCs its body, after which eviction +could no longer re-read it to decrement (a permanent leak). Hence `txCacheMaxAge` < time-to-immutability +(the body is guaranteed still present when we age-evict) and comfortably above a healthy `128`-EB span (so it +never bites during normal flow). ~8 hr seems sufficient. + +**Persistence / restart.** The bytes are durable in the backing store; the in-memory index is not persisted, +but the `≤128` window is. `BEH-Startup` rebuilds the index by reading those windowed EBs' bodies, and GCs the +TxCache (against the jumped wall clock) before pruning the store — so the bodies the age-eviction re-reads are +still present. A restart is a fresh process, so that ordering is a free, deliberate step; after a long downtime +the whole window is past `txCacheMaxAge` and ages out at once → cold cache (consistent with inert-while-syncing), +after a brief one it is kept. + +This design does not yet support resume-from-suspend. There the process stays live while the wall clock jumps +mid-flight: the wall-clock-driven age-eviction fires on resume and races the (tip-driven) LeiosDB volatile GC, +and a TxCache reader (`dbCopyFromTxCache`) can race the eviction deleting the same bytes. A GC delay armed +before the suspend is no help — its window has effectively elapsed across the suspend. The robust fix is +pinning: GC, in both stores, skips bytes `LstTxCacheWindow` still references, rather than relying on timing — +deferred (TODO). So restarts are supported; suspend/resume is not yet. + +**Properties.** Load-bearing for throughput (its absence collapses throughput under fragmentation). Sound (a +reported hit is genuinely held — never a false hit, which would stall a closure); recall bounded by a +deliberate space–time trade-off (the window bounds memory/disk; reuse beyond it re-fetches). Bounded memory (the one index + the `128` +window; backing store bounded by requirement) and bounded disk (≈ the window, via prompt eviction). +Adversary-resistant: the `30s` gate admits only timely announcements (no withheld-then-bursted reshaping), and +only the first-announced EB per election takes a slot, so admissions are sortition-rate-limited — equivocations +and offer bursts can't inflate the window. Inert while syncing: the announcements seen during catch-up are for +old slots (well past `30s`), so none qualify and none are admitted — a node that has been behind for a while +simply has an empty cache (and anything carried in from before drains over `txCacheMaxAge`). + +**Parameters.** `128` (window EBs) · `30s` (announcement promptness) · `txCacheMaxAge` (~8 h, < time-to-immutability). + +## §8 Interfaces with out-of-scope components + +This document scopes out RB and EB creation (the "block forging thread"), voting, the Inbound Peer Governor, ChainSel's acquired-set/reprocess machinery, and +GC/promote. Some of those neighbors still need to read state this document owns, or feed events into it — +meaning small embellishments here. Collected so they aren't forgotten when those components are built; not +specified in detail. + +**Voting.** +- **Per-tx validated flag.** Voting needs the TxCache to record, per tx, whether it has ever been successfully + validated — a `validated` field alongside `(refcount, acquired)` in `LstTxCacheIndex`, with hooks to set and + read it. Cheap for a Mempool tx (set it at once via `txCacheOnAcquire`, since the Mempool holds only validated + txs); a peer-fetched tx is unvalidated until checked. (Moved here from §7.) +- **Timely-announcement set.** Voting needs the EB announcements that arrived within `L_hdr` of their slot + onset — either we maintain that set or voting queries per-announcement timeliness. We already record + arrival-vs-slot for the TxCache's `30s` gate (§7), so an `L_hdr`-keyed view of the same is a near relative. +- **Cert generation feeds back in (full SF).** Under the full skew fallback our own voting logic may produce a + cert; we ingest it as `LevCertValidated` — a third emitter, alongside ChainSel's CertRB path and **[SF]** + `BEH-CertFetch`. (Direction here is voting → us, not a read.) + +**Inbound Peer Governor.** +- **First provider per election.** The governor may want which peer first delivered our first-seen announcement + for each election (to credit peers that diffuse fresh EBs promptly). `LstFirstAnnouncements` is peerless + today; this would additionally record, per election, the peer behind the first-seen announcement. From 2a126699ac9defd0d10d8d9c1959f729a50fa291 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sat, 27 Jun 2026 05:31:36 -0400 Subject: [PATCH 02/16] WIP now actually writing Haskell --- .../Test/Leios/RefModel/RefModel.hs | 972 ++++++++++++++++++ .../Test/Leios/RefModel/Spec.md | 316 ++++-- .../Test/Leios/RefModel/test/RefModelTest.hs | 235 +++++ 3 files changed, 1421 insertions(+), 102 deletions(-) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs new file mode 100644 index 0000000000..a955ddc33a --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -0,0 +1,972 @@ +module RefModel where + +import Data.Foldable (foldl', toList) +import Data.List (maximumBy, minimumBy, sortOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet +import Data.These (These (..)) +import Data.Word (Word16, Word64) + +newtype ByteCount = ByteCount Word64 deriving (Eq, Num, Ord, Show) +newtype Slot = Slot Word64 deriving (Eq, Ord, Show) +newtype PoolId = PoolId Word64 deriving (Eq, Ord, Show) +newtype Peer = Peer Word64 deriving (Eq, Ord, Show) +newtype EbHash = EbHash Word64 deriving (Eq, Ord, Show) +newtype HeaderHash = HeaderHash Word64 deriving (Eq, Ord, Show) +newtype TxHash = TxHash Word64 deriving (Eq, Ord, Show) +newtype JobId = JobId Word64 deriving (Eq, Ord, Show) +newtype Time = Time Word64 deriving (Eq, Ord, Show) + +data Election = Election Slot PoolId -- election = (slot, pool) + deriving (Eq, Ord, Show) + +electionSlot :: Election -> Slot +electionSlot (Election s _) = s + +data Class = StakeSampled | PeerSharingSampled -- BEH-PeerClass + deriving (Eq, Ord, Show) + +data Phase = Active | WindingDown -- §2 LstPeerPresent + deriving (Eq, Ord, Show) + +data EbAnn = EbAnn -- §Conventions announcement + { annEbHash :: EbHash + , annBodySize :: ByteCount + , annClosureSize :: ByteCount + } + deriving (Eq, Ord, Show) + +data RbHeader = RbHeader -- §Conventions · §3 LevRollForward + { rbHeaderHash :: HeaderHash + , rbElection :: Election + , rbAnnounce :: Maybe EbAnn + , rbHasLeiosCert :: Bool + , rbValid :: Bool + } + deriving (Eq, Ord, Show) + +election :: RbHeader -> Election -- §Conventions election(header) +election = rbElection + +data TxRef = TxRef { txRefHash :: TxHash, txRefSize :: ByteCount } -- §Conventions tx (hash + size) + deriving (Eq, Ord, Show) + +data Body = Body -- §Conventions closure / txseq + { bodyEbHash :: EbHash + , bodyTxlist :: [TxRef] + , bodyActualSize :: ByteCount + } + deriving (Eq, Show) + +data Tx = Tx { txHash :: TxHash, txSize :: ByteCount } + deriving (Eq, Ord, Show) + +data AnnouncementTriple = AnnouncementTriple -- §3 LevRollForward / LevCertValidated (announced-EB identity) + { atElection :: Election + , atHeaderHash :: HeaderHash + , atEbHash :: EbHash + } + deriving (Eq, Ord, Show) + +data AnnState = AnnOne RbHeader | AnnTwo RbHeader RbHeader -- §2 LstFirstAnnouncements + deriving (Eq, Show) + +data AnnSeen = SeenOne RbHeader | SeenTwo RbHeader -- §2 LstPeerFirstAnnouncements + deriving (Eq, Show) + +seenFirst :: AnnSeen -> RbHeader +seenFirst (SeenOne h) = h +seenFirst (SeenTwo h1) = h1 + +annEbHashOf :: RbHeader -> Maybe EbHash +annEbHashOf = fmap annEbHash . rbAnnounce + +data OfferSide = OfferBody | OfferBodyAndClosure -- §2 LstPeerOfferings / OfferSide + deriving (Eq, Ord, Show) + +data CertSide = CertSide HeaderHash EbHash -- §2 LstPeerOfferings / CertSide + deriving (Eq, Show) + +data Job = Job (NonEmpty TxHash) ByteCount -- §2 Job (ordered txs + byte size) + deriving (Eq, Ord, Show) + +jobTxs :: Job -> NonEmpty TxHash +jobTxs (Job txs _) = txs + +jobByteSize :: Job -> ByteCount +jobByteSize (Job _ n) = n + +newtype OutstandingDiskWritesLessOne = OutstandingDiskWritesLessOne Word16 -- §2 AwaitingTxs: one less than the closure's outstanding DiskWrites + deriving (Eq, Ord, Show) + +data WantState -- §2 LstWanted / WantState + = AwaitingBody EbHash ByteCount ByteCount + | AwaitingTxs EbHash (These (NEMap JobId Job) OutstandingDiskWritesLessOne) + deriving (Eq, Show) + +wantEb :: WantState -> EbHash +wantEb (AwaitingBody eh _ _) = eh +wantEb (AwaitingTxs eh _) = eh + +mkTxsState :: Map JobId Job -> Word16 -> Maybe (These (NEMap JobId Job) OutstandingDiskWritesLessOne) -- §2 AwaitingTxs payload; Nothing ⇒ closure fully fetched and persisted +mkTxsState jobs writes = case (NEMap.nonEmptyMap jobs, writes) of + (Nothing, 0) -> Nothing + (Just j, 0) -> Just (This j) + (Nothing, n) -> Just (That (OutstandingDiskWritesLessOne (n - 1))) + (Just j, n) -> Just (These j (OutstandingDiskWritesLessOne (n - 1))) + +txsFetch :: These (NEMap JobId Job) OutstandingDiskWritesLessOne -> Map JobId Job -- §2 AwaitingTxs jobs still awaiting a response +txsFetch (This j) = NEMap.toMap j +txsFetch (That _) = Map.empty +txsFetch (These j _) = NEMap.toMap j + +txsWrites :: These (NEMap JobId Job) OutstandingDiskWritesLessOne -> Word16 -- §2 AwaitingTxs outstanding DiskWrites +txsWrites (This _) = 0 +txsWrites (That (OutstandingDiskWritesLessOne n)) = n + 1 +txsWrites (These _ (OutstandingDiskWritesLessOne n)) = n + 1 + +decTxsState :: These (NEMap JobId Job) OutstandingDiskWritesLessOne -> Maybe (These (NEMap JobId Job) OutstandingDiskWritesLessOne) -- §3 LevDiskDone: one DiskWrite finished +decTxsState t = case txsWrites t of + 0 -> error "decTxsState: a LevDiskDone arrived with no outstanding write" + n -> mkTxsState (txsFetch t) (n - 1) + +setTxs :: Election -> EbHash -> Map JobId Job -> Word16 -> St -> St -- §2 LstWanted AwaitingTxs (cleared when nothing is outstanding) +setTxs el eh jobs writes st = case mkTxsState jobs writes of + Just t -> setWant el (AwaitingTxs eh t) st + Nothing -> removeWant el st + +data Req -- §2 LstPeerInflight / Req + = ReqBody Election EbHash ByteCount ByteCount -- bodySize and closureSize, for validation + | ReqJob Election EbHash JobId Job -- the job itself, for validation + deriving (Eq, Ord, Show) + +data PeerInfo = PeerInfo { peerClass :: Class, peerPhase :: Phase } -- §2 LstPeerPresent + deriving (Eq, Show) + +data Notification -- §2 LstPeerNotifyQueue + = NotifyAnnouncement RbHeader + | NotifyEquivProof (Maybe RbHeader) RbHeader + | NotifyBlockOffer Election EbHash -- MsgLeiosBlockOffer + | NotifyBlockTxsOffer Election EbHash -- MsgLeiosBlockTxsOffer + deriving (Eq, Ord, Show) + +data St = St + { stFirstAnnouncements :: Map Election AnnState -- §2 LstFirstAnnouncements + , stPeerFirstAnnouncements :: Map Peer (Map Election AnnSeen) -- §2 LstPeerFirstAnnouncements + , stPeerOfferings :: Map Peer (Map Election (These CertSide OfferSide)) -- §2 LstPeerOfferings + , stPeerOfferGates :: Map Peer (Map Election EbHash) -- §2 LstPeerOfferGates + , stPeerNotifyQueue :: Map Peer (Set Notification, Int) -- §2 LstPeerNotifyQueue + , stWanted :: Map Election WantState -- §2 LstWanted + , stCertified :: Map Election (HeaderHash, EbHash) -- §2 LstCertified + , stPeerInflight :: Map Peer (Seq Req) -- §2 LstPeerInflight + , stPeerPresent :: Map Peer PeerInfo -- §2 LstPeerPresent + } + deriving (Eq, Show) + +emptySt :: St -- BEH-Startup +emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty + +data Env = Env + { envStakeMaxActiveEbs :: Int -- §2 stakeMaxActiveEbs + , envPeerSharingMaxActiveEbs :: Int -- §2 peerSharingMaxActiveEbs + , envPeerSharingClosureByteLimit :: ByteCount -- §2 peerSharingClosureByteLimit + , envJobSize :: ByteCount -- §2 jobSize + , envRequestTimeout :: Word64 -- §2 requestTimeout + , envNotifyMaxCapacity :: Int -- §2 notifyMaxCapacity + , envNotifyStaleHorizon :: Word64 -- §2 notifyStaleHorizon (slots; ≈ 10 min) + , envImmutableTip :: Slot -- ChainDB-owned, harness-updated + } + deriving (Eq, Show) + +maxActiveEbs :: Env -> Class -> Int -- §3 active-EB cap +maxActiveEbs env StakeSampled = envStakeMaxActiveEbs env +maxActiveEbs env PeerSharingSampled = envPeerSharingMaxActiveEbs env + +belowTip :: Env -> Election -> Bool -- BEH-ImmTipAdvance +belowTip env el = electionSlot el < envImmutableTip env + +data DbKey = DbBody EbHash | DbClosureTx EbHash TxHash -- §2 dbQueryPresent keys + deriving (Eq, Ord, Show) + +data LeiosDb m = LeiosDb -- §2 disk store interface + { dbQueryPresent :: Set DbKey -> m (Set DbKey) -- BEH-Completion / BEH-FetchServe + , dbReadBody :: EbHash -> m (Maybe Body) -- BEH-Completion + , dbReadClosureTxs :: EbHash -> [TxHash] -> m [Tx] -- BEH-FetchServe + } + +data TxCache m = TxCache -- §7 TxCache hooks + { txCacheNoteAnnouncement :: EbHash -> m () -- BEH-Wanting + , txCacheOnBody :: EbHash -> Set TxHash -> m [Tx] -- BEH-ChunkJobs + , txCacheOnAcquire :: [Tx] -> m () -- BEH-Responses + } + +data Mempool m = Mempool -- §2 Reads of un-owned state + { mempoolQueryPresent :: Set TxHash -> m [Tx] } -- BEH-ChunkJobs + +data Ifaces m = Ifaces { ifDb :: LeiosDb m, ifTxc :: TxCache m, ifMem :: Mempool m } + +data WireMsg -- §2 Wire messages + = MsgLeiosNotificationRequestNext + | MsgLeiosBlockAnnouncement RbHeader + | MsgLeiosBlockEquivocationProof (Maybe RbHeader) RbHeader + | MsgLeiosBlockOffer Election EbHash + | MsgLeiosBlockTxsOffer Election EbHash + | MsgLeiosBlockRequest EbHash + | MsgLeiosBlock EbHash Body + | MsgLeiosBlockTxsRequest EbHash (NonEmpty TxHash) + | MsgLeiosBlockTxs EbHash [Tx] + deriving (Eq, Show) + +data Stimulus -- §2 Stimuli + = LevWiredMsg Peer WireMsg + | LevRollForward Peer RbHeader (Maybe AnnouncementTriple) -- BEH-Offers / BEH-Wanting + | LevCertValidated AnnouncementTriple ByteCount ByteCount -- BEH-Wanting / BEH-FetchPriority (bodySize, closureSize) + | LevPeerAdd Peer Class -- BEH-PeerChurn + | LevPeerWindDown Peer -- BEH-PeerChurn + | LevPeerRemove Peer -- BEH-PeerChurn + | LevTimer Time Peer Req -- BEH-Timeout + | LevDiskDone DiskWrite -- §3 LevDiskDone (only writes signal completion) + | LevImmTipAdvanced -- BEH-ImmTipAdvance (slot read from envImmutableTip) + | LevGarbageCollect Slot -- BEH-ImmTipAdvance + | LevSelfIssued RbHeader Body -- BEH-SelfIssued + | LevNotifyDequeue Peer -- BEH-NotifyServe + deriving (Eq, Show) + +data DiskWrite -- §2 disk store interface (writes; each yields one LevDiskDone) + = WriteBody Election Body + | WriteClosure Election EbHash [Tx] + deriving (Eq, Show) + +data DiskOp -- §2 disk store interface (scheduled actions) + = Write DiskWrite + | GarbageCollect Slot + | Promote Slot + deriving (Eq, Show) + +data Offence -- §3 disconnect reasons (carried by Disconnect) + = NotAnAnnouncement -- a LeiosNotify announcement that announces no EB + | InvalidHeader -- header failed validation + | AnnouncementBound -- re-announced, or exceeded the per-peer two-first-announcements bound + | BogusEquivocationProof -- did not prove a genuine equivocation + | UnannouncedOffer -- offered an EB the peer never first-announced + | CertConflict -- cert for a HeaderHash conflicting with our validated cert + | BodyMismatch -- body disagrees with the request (hash / size / closure size) + | TxsMismatch -- closure txs disagree with the requested job (content or order) + | UnsolicitedResponse -- a response matching no front in-flight request + | RequestedAbsentData -- requested body/txs we do not hold + | RequestTimeout -- an in-flight request went overdue + | ExcessNotifyCredits -- extended more notify credits than notifyMaxCapacity allows + | StaleNotification -- a LeiosNotify message whose slot is > notifyStaleHorizon below the immutable tip + deriving (Eq, Ord, Show) + +data Effect -- §2 Actions + = Send Peer WireMsg + | Disconnect Peer Offence + | SubmitDisk DiskOp + | SetTimer Peer Req Time + | NotifyVotingAndChainSel Election EbHash -- BEH-Completion (persisted closure → voting + ChainSel) + | NotifyEnqueue Peer -- BEH-NotifyServe + deriving (Eq, Show) + +classOf :: St -> Peer -> Maybe (Class, Phase) +classOf st peer = (\pi_ -> (peerClass pi_, peerPhase pi_)) <$> Map.lookup peer (stPeerPresent st) + +activePeers :: St -> [Peer] -- NEEDS-TO-BE-INCREMENTAL: maintained set of Active peers +activePeers st = [ peer | (peer, pi_) <- Map.toList (stPeerPresent st), peerPhase pi_ == Active ] + +inflightOf :: St -> Peer -> Seq Req +inflightOf st peer = fromMaybe Seq.empty (Map.lookup peer (stPeerInflight st)) + +inflightHas :: St -> Peer -> Req -> Bool -- NEEDS-TO-BE-INCREMENTAL: per-peer requested-Req set +inflightHas st peer r = r `elem` inflightOf st peer + +activeEbs :: St -> Peer -> Set EbHash -- §2 activeEbs · NEEDS-TO-BE-INCREMENTAL: per-peer active-EB set +activeEbs st peer = Set.fromList (map reqEb (toList (inflightOf st peer))) + +reqEb :: Req -> EbHash +reqEb (ReqBody _ eh _ _) = eh +reqEb (ReqJob _ eh _ _) = eh + +reqElection :: Req -> Election +reqElection (ReqBody el _ _ _) = el +reqElection (ReqJob el _ _ _) = el + +jobInflightPeers :: St -> EbHash -> JobId -> Int -- §2 jobInflightPeers · NEEDS-TO-BE-INCREMENTAL: (EbHash,JobId)↦in-flight-peer-count index +jobInflightPeers st eh j = + length [ () | (_, sq) <- Map.toList (stPeerInflight st) + , ReqJob _ eh' j' _ <- toList sq + , eh' == eh, j' == j ] + +peerSharingInFlightBytes :: St -> Peer -> EbHash -> ByteCount -- §2 peerSharingInFlightBytes · NEEDS-TO-BE-INCREMENTAL: per-(peer,EbHash) in-flight byte total +peerSharingInFlightBytes st peer eh = + sum [ jobByteSize job + | ReqJob _ eh' _ job <- toList (inflightOf st peer), eh' == eh ] + +jobBytes :: St -> Election -> EbHash -> JobId -> ByteCount +jobBytes st el _ j = + case Map.lookup el (stWanted st) of + Just (AwaitingTxs _ t) -> maybe 0 jobByteSize (Map.lookup j (txsFetch t)) + _ -> 0 + +wantedStateOf :: St -> EbHash -> Maybe (Election, WantState) -- §2 LstWanted · NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦Election index +wantedStateOf st eh = + case [ (el, ws) | (el, ws) <- Map.toList (stWanted st), wantEb ws == eh ] of + (x : _) -> Just x + [] -> Nothing + +wants :: St -> Election -> EbHash -> Bool +wants st el eh = case Map.lookup el (stWanted st) of + Just ws -> wantEb ws == eh + Nothing -> False + +offeredEb :: St -> Peer -> Election -> These CertSide OfferSide -> Maybe EbHash -- §2 LstPeerOfferings +offeredEb st peer el side = case side of + This (CertSide _ eh) -> Just eh + These (CertSide _ eh) _ -> Just eh + That _ -> firstAnnouncedEb st peer el + +firstAnnouncedEb :: St -> Peer -> Election -> Maybe EbHash -- §2 LstPeerFirstAnnouncements +firstAnnouncedEb st peer el = do + perPeer <- Map.lookup peer (stPeerFirstAnnouncements st) + seen <- Map.lookup el perPeer + annEbHashOf (seenFirst seen) + +electionOf :: St -> Peer -> EbHash -> Maybe (NESet Election) -- §2 electionOf (first-announced only) · NEEDS-TO-BE-INCREMENTAL: per-peer reverse EbHash↦Elections index +electionOf st peer eh = + NESet.nonEmptySet $ Set.fromList + [ el + | (el, seen) <- Map.toList (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st))) + , annEbHashOf (seenFirst seen) == Just eh ] + +offerersBody :: St -> EbHash -> Set Peer -- §2 offerersBody · BEH-BodyFetch +offerersBody st eh = offerersAtLeast st eh OfferBody + +offerersClosure :: St -> EbHash -> Set Peer -- §2 offerersClosure · BEH-ClosureFetch +offerersClosure st eh = offerersAtLeast st eh OfferBodyAndClosure + +offerersAtLeast :: St -> EbHash -> OfferSide -> Set Peer -- NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦offering-peers index +offerersAtLeast st eh need = Set.fromList + [ peer + | (peer, els) <- Map.toList (stPeerOfferings st) + , (el, side) <- Map.toList els + , offeredEb st peer el side == Just eh + , offerLevelAtLeast side need ] + +offerLevelAtLeast :: These CertSide OfferSide -> OfferSide -> Bool +offerLevelAtLeast side need = case offerLevel side of + Just lvl -> lvl >= need + Nothing -> False + +offerLevel :: These CertSide OfferSide -> Maybe OfferSide +offerLevel (This _) = Nothing +offerLevel (That lvl) = Just lvl +offerLevel (These _ lvl) = Just lvl + +offeredWanted :: St -> Peer -> [EbHash] -- NEEDS-TO-BE-INCREMENTAL: per-peer offered∩wanted set +offeredWanted st peer = + [ eh + | ws <- Map.elems (stWanted st) + , let eh = wantEb ws + , peer `Set.member` offerersBody st eh || peer `Set.member` offerersClosure st eh ] + +fetchPriorityOrder :: St -> [EbHash] -> [EbHash] -- BEH-FetchPriority · NEEDS-TO-BE-INCREMENTAL: maintained priority order, not a per-decision re-sort +fetchPriorityOrder st ebs = sortOn (priorityKey st) ebs + +newtype NotificationPriority = NotificationPriority Word64 + deriving (Eq, Num, Ord, Show) + +priorityKey :: St -> EbHash -> (NotificationPriority, Slot) +priorityKey st eh = + case wantedStateOf st eh of + Just (el, _) + | isCertifiedEb st el eh -> (0, electionSlot el) + | otherwise -> (1, invertSlot (electionSlot el)) + Nothing -> (2, Slot 0) + +isCertifiedEb :: St -> Election -> EbHash -> Bool +isCertifiedEb st el eh = case Map.lookup el (stCertified st) of + Just (_, ceb) -> ceb == eh + Nothing -> False + +invertSlot :: Slot -> Slot +invertSlot (Slot s) = Slot (maxBound - s) + +decide :: Env -> St -> Peer -> [Req] -- §3 Decision · BEH-BodyFetch · BEH-ClosureFetch · BEH-FetchPriority +decide env st peer = + case classOf st peer of + Just (cls, Active) -> concatMap (decideForEb env st peer cls) (admittedEbs env st peer cls) + _ -> [] + +admittedEbs :: Env -> St -> Peer -> Class -> [EbHash] -- §3 active-EB cap · BEH-FetchPriority +admittedEbs env st peer cls = + let already = activeEbs st peer + cap = maxActiveEbs env cls + grow _ [] = [] + grow seen (eh : ebs) + | eh `Set.member` already = eh : grow seen ebs + | Set.size seen < cap = eh : grow (Set.insert eh seen) ebs + | otherwise = grow seen ebs + in grow already (fetchPriorityOrder st (offeredWanted st peer)) + +decideForEb :: Env -> St -> Peer -> Class -> EbHash -> [Req] -- §3 Body · Stake closure · PeerShare closure +decideForEb env st peer cls eh = + case wantedStateOf st eh of + Just (el, AwaitingBody _ bs cs) | peer `Set.member` offerersBody st eh -> + [ ReqBody el eh bs cs | not (inflightHas st peer (ReqBody el eh bs cs)) ] + Just (el, AwaitingTxs _ t) | peer `Set.member` offerersClosure st eh -> + case cls of + StakeSampled -> + [ ReqJob el eh j job + | (j, job) <- Map.toList (txsFetch t) + , not (inflightHas st peer (ReqJob el eh j job)) ] + PeerSharingSampled -> peerShareJobs env st peer el eh (txsFetch t) + _ -> [] + +peerShareJobs :: Env -> St -> Peer -> Election -> EbHash -> Map JobId Job -> [Req] -- §3 PeerShare closure · BEH-ClosureFetch +peerShareJobs env st peer el eh jobs = + let budget = envPeerSharingClosureByteLimit env - peerSharingInFlightBytes st peer eh + candidates = sortOn (\(j, _) -> (jobInflightPeers st eh j, frontSkewKey j)) + [ (j, job) | (j, job) <- Map.toList jobs + , not (inflightHas st peer (ReqJob el eh j job)) ] + in takeWhileBudget budget [ (jobByteSize job, ReqJob el eh j job) | (j, job) <- candidates ] + +frontSkewKey :: JobId -> Word64 -- §3 Job ordering (frontSkew) +frontSkewKey (JobId j) = j + +takeWhileBudget :: ByteCount -> [(ByteCount, Req)] -> [Req] +takeWhileBudget _ [] = [] +takeWhileBudget budget ((b, r) : rest) + | b <= budget = r : takeWhileBudget (budget - b) rest + | otherwise = [] + +chunk :: Env -> [TxRef] -> Map JobId Job -- BEH-ChunkJobs · §2 Job (≈ jobSize batches) +chunk env trs = + Map.fromList (zip (map JobId [0 ..]) (map mkJob (batchBySize (envJobSize env) trs))) + where mkJob batch = Job (NE.fromList (map txRefHash batch)) (sum (map txRefSize batch)) + +batchBySize :: ByteCount -> [TxRef] -> [[TxRef]] -- §2 jobSize +batchBySize _ [] = [] +batchBySize limit (x : xs) = go [x] (txRefSize x) xs + where + go acc _ [] = [reverse acc] + go acc sz (t : ts) + | sz + txRefSize t > limit && not (null acc) = reverse acc : go [t] (txRefSize t) ts + | otherwise = go (t : acc) (sz + txRefSize t) ts + +hashes :: [Tx] -> Set TxHash +hashes = Set.fromList . map txHash + +step :: Monad m => Ifaces m -> Env -> Time -> Stimulus -> St -> m (St, [Effect]) -- §3 +step ifs env now stim st = case stim of + LevWiredMsg peer msg -> stepWired ifs env now peer msg st + LevRollForward peer h pe -> hRollForward ifs env now peer h pe st + LevCertValidated at bs cs -> hCertValidated ifs env now at bs cs st + LevPeerAdd peer cls -> hPeerAdd peer cls st + LevPeerWindDown peer -> hPeerWindDown env now peer st + LevPeerRemove peer -> hPeerRemove env now peer st + LevTimer _ peer req -> hTimer peer req st + LevDiskDone w -> hDiskDone ifs env now w st + LevImmTipAdvanced -> hImmTipAdvanced env st + LevGarbageCollect s -> hGarbageCollect s st + LevSelfIssued h body -> hSelfIssued ifs env now h body st + LevNotifyDequeue peer -> hNotifyDequeue env peer st + +stepWired :: Monad m => Ifaces m -> Env -> Time -> Peer -> WireMsg -> St -> m (St, [Effect]) +stepWired ifs env now peer msg st + | Just s <- notifyMsgSlot st peer msg, notifyStale env s = pure (st, [Disconnect peer StaleNotification]) + | otherwise = case msg of + MsgLeiosNotificationRequestNext -> hRequestNext env peer st + MsgLeiosBlockAnnouncement h -> hAnnouncement ifs env now peer h st + MsgLeiosBlockEquivocationProof m1 h2 -> hEquivProof env peer m1 h2 st + MsgLeiosBlockOffer el eh -> hOffer env now peer el eh OfferBody st + MsgLeiosBlockTxsOffer el eh -> hOffer env now peer el eh OfferBodyAndClosure st + MsgLeiosBlockRequest eh -> hServeBody ifs env now peer eh st + MsgLeiosBlock eh body -> hBlock ifs env now peer eh body st + MsgLeiosBlockTxsRequest eh txs -> hServeTxs ifs env now peer eh txs st + MsgLeiosBlockTxs eh txs -> hBlockTxs ifs env now peer eh txs st + +hAnnouncement :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockAnnouncement +hAnnouncement ifs env now peer h st = case rbAnnounce h of + Nothing -> pure (st, [Disconnect peer NotAnAnnouncement]) + Just ann + | not (rbValid h) -> pure (st, [Disconnect peer InvalidHeader]) + | otherwise -> + case advancePeerAnn peer (rbElection h) h st of + Nothing -> pure (st, [Disconnect peer AnnouncementBound]) + Just st1 -> do + txCacheNoteAnnouncement (ifTxc ifs) (annEbHash ann) + (st2, fx) <- centralAnnounce ifs env now h st1 + pure (st2, fx) + +hEquivProof :: Monad m => Env -> Peer -> Maybe RbHeader -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockEquivocationProof +hEquivProof env peer mh1 h2 st = + case maybe (recordedFirst st peer (rbElection h2)) Just mh1 of + Nothing -> pure (st, [Disconnect peer BogusEquivocationProof]) + Just h1 + | not (genuineEquiv h1 h2) -> pure (st, [Disconnect peer BogusEquivocationProof]) + | otherwise -> case advancePeerToTwo peer (rbElection h2) h1 st of + Nothing -> pure (st, [Disconnect peer BogusEquivocationProof]) + Just st1 -> let (st2, fx) = centralEquiv env (rbElection h2) h1 h2 st1 + in pure (st2, fx) + +recordedFirst :: St -> Peer -> Election -> Maybe RbHeader -- §2 LstPeerFirstAnnouncements +recordedFirst st peer el = do + perPeer <- Map.lookup peer (stPeerFirstAnnouncements st) + seenFirst <$> Map.lookup el perPeer + +genuineEquiv :: RbHeader -> RbHeader -> Bool -- §3 LevBlockEquivocationProof validation +genuineEquiv h1 h2 = + rbValid h1 && rbValid h2 + && isJust (rbAnnounce h1) && isJust (rbAnnounce h2) + && rbElection h1 == rbElection h2 + && rbHeaderHash h1 /= rbHeaderHash h2 + +advancePeerToTwo :: Peer -> Election -> RbHeader -> St -> Maybe St -- §3 LstPeerFirstAnnouncements -> Two +advancePeerToTwo peer el h1 st = + let perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)) + putTwo = st { stPeerFirstAnnouncements = + Map.insert peer (Map.insert el (SeenTwo h1) perPeer) (stPeerFirstAnnouncements st) } + in case Map.lookup el perPeer of + Nothing -> Just putTwo + Just (SeenOne f) | rbHeaderHash f == rbHeaderHash h1 -> Just putTwo + | otherwise -> Nothing + Just (SeenTwo{}) -> Nothing + +centralEquiv :: Env -> Election -> RbHeader -> RbHeader -> St -> (St, [Effect]) -- §3 LevBlockEquivocationProof central branch +centralEquiv env el h1 h2 st = + case Map.lookup el (stFirstAnnouncements st) of + Just (AnnTwo{}) -> (st, []) + prev -> + let st1 = st { stFirstAnnouncements = Map.insert el (AnnTwo h1 h2) (stFirstAnnouncements st) } + st2 = case prev of + Nothing | not (belowTip env el) -> ensureWantedBodyAnn st1 el h1 + _ -> st1 + in enqueueToAll (NotifyEquivProof (Just h1) h2) st2 + +ensureWantedBodyAnn :: St -> Election -> RbHeader -> St +ensureWantedBodyAnn st el h = case rbAnnounce h of + Just a -> setWant el (AwaitingBody (annEbHash a) (annBodySize a) (annClosureSize a)) st + Nothing -> st + +hOffer :: Monad m => Env -> Time -> Peer -> Election -> EbHash -> OfferSide -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer +hOffer env now peer el eh lvl st = case recordedFirst st peer el of + Just h | annEbHashOf h == Just eh -> considerFetchAfter env now (raiseOffer peer (NESet.singleton el) lvl st) [] + _ -> pure (st, [Disconnect peer UnannouncedOffer]) + +hRollForward :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> Maybe AnnouncementTriple -> St -> m (St, [Effect]) -- BEH-Offers / BEH-Wanting · §3 LevRollForward +hRollForward ifs env now peer h pe st = do + (st1, fx1) <- case rbAnnounce h of + Nothing -> pure (st, []) + Just _ -> centralAnnounce ifs env now h st + let (st2, fx2) = case (rbHasLeiosCert h, pe) of + (True, Just at) -> rollForwardCert peer at st1 + _ -> (st1, []) + considerFetchAfter env now st2 (fx1 ++ fx2) + +rollForwardCert :: Peer -> AnnouncementTriple -> St -> (St, [Effect]) -- §3 LevRollForward cert bit +rollForwardCert peer at st = + let el = atElection at + conflict = case Map.lookup el (stCertified st) of + Just (hh, _) -> hh /= atHeaderHash at + Nothing -> False + in if conflict + then (st, [Disconnect peer CertConflict]) + else (recordCertSide peer el (atHeaderHash at) (atEbHash at) st, []) + +recordCertSide :: Peer -> Election -> HeaderHash -> EbHash -> St -> St -- §3 LevRollForward CertSide +recordCertSide peer el hh eh st = + st { stPeerOfferings = Map.insert peer (Map.insert el side perPeer) (stPeerOfferings st) } + where + perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferings st)) + side = These (CertSide hh eh) OfferBodyAndClosure + +hRequestNext :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotificationRequestNext +hRequestNext env peer st = + let (s, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + in if cap >= envNotifyMaxCapacity env + then pure (st, [Disconnect peer ExcessNotifyCredits]) + else pure (setQueue peer (s, cap + 1) st, []) + +hNotifyDequeue :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotifyDequeue +hNotifyDequeue env peer st = + let (s, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + in case pickMax s of + Nothing -> error "hNotifyDequeue: LevNotifyDequeue on an empty queue" + Just (n, s') + | belowTip env (notifyElection n) -> pure (setQueue peer (s', cap) st, []) + | otherwise -> pure (sendNotification peer n (setQueue peer (s', cap - 1) st)) + +setQueue :: Peer -> (Set Notification, Int) -> St -> St +setQueue peer v st = st { stPeerNotifyQueue = Map.insert peer v (stPeerNotifyQueue st) } + +enqueue :: Notification -> (Set Notification, Int) -> (Set Notification, Int) -- BEH-NotifyServe +enqueue n (q, cap) = + let q' = Set.insert n q + in if Set.size q' > cap + then (Set.delete (minimumBy (comparing notifyRank) (Set.toList q')) q', cap) + else (q', cap) + +enqueueTo :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe +enqueueTo peer n st = + let (q, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + (q', _) = enqueue n (q, cap) + in (setQueue peer (q', cap) st, [ NotifyEnqueue peer | Set.size q' > Set.size q ]) + +enqueueToAll :: Notification -> St -> (St, [Effect]) -- BEH-NotifyServe relay +enqueueToAll n st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer n s in (s', fx ++ fx')) (st, []) (Map.keys (stPeerPresent st)) + +pickMax :: Set Notification -> Maybe (Notification, Set Notification) -- §2 notifyPriority · NEEDS-TO-BE-INCREMENTAL: two slot-ordered queues (announcements; non-announcements) +pickMax s + | Set.null s = Nothing + | otherwise = let n = maximumBy (comparing notifyRank) (Set.toList s) in Just (n, Set.delete n s) + +notifyRank :: Notification -> (NotificationPriority, Word64) -- §2 notifyPriority (simplified; L_hdr tiers TODO) +notifyRank (NotifyAnnouncement h) = (3, slotW (rbElection h)) +notifyRank (NotifyEquivProof _ h2) = (2, slotW (rbElection h2)) +notifyRank (NotifyBlockTxsOffer el _) = (1, slotW el) +notifyRank (NotifyBlockOffer el _) = (1, slotW el) + +slotW :: Election -> Word64 +slotW (Election (Slot s) _) = s + +notifyElection :: Notification -> Election -- §2 notification's election (for BEH-ImmTipAdvance staleness) +notifyElection (NotifyAnnouncement h) = rbElection h +notifyElection (NotifyEquivProof _ h2) = rbElection h2 +notifyElection (NotifyBlockOffer el _) = el +notifyElection (NotifyBlockTxsOffer el _) = el + +notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot (youngest, for a multi-election EbHash offer) +notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) +notifyMsgSlot _ _ (MsgLeiosBlockEquivocationProof _ h2) = Just (electionSlot (rbElection h2)) +notifyMsgSlot _ _ (MsgLeiosBlockOffer el _) = Just (electionSlot el) +notifyMsgSlot _ _ (MsgLeiosBlockTxsOffer el _) = Just (electionSlot el) +notifyMsgSlot _ _ _ = Nothing + +notifyStale :: Env -> Slot -> Bool -- BEH-NotifyServe staleness: slot-difference (as a duration) exceeds notifyStaleHorizon +notifyStale env (Slot s) = case envImmutableTip env of Slot tip -> tip > s + envNotifyStaleHorizon env + +sendNotification :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe +sendNotification peer n st = case n of + NotifyAnnouncement h -> + let el = rbElection h + eh = maybe (EbHash 0) annEbHash (rbAnnounce h) + in (openGate peer el eh st, [Send peer (MsgLeiosBlockAnnouncement h)]) + NotifyEquivProof m1 h2 -> (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) + NotifyBlockOffer el eh -> (st, [Send peer (MsgLeiosBlockOffer el eh)]) + NotifyBlockTxsOffer el eh -> (st, [Send peer (MsgLeiosBlockTxsOffer el eh)]) + +openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates +openGate peer el eh st = + st { stPeerOfferGates = Map.insert peer (Map.insert el eh perPeer) (stPeerOfferGates st) } + where perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferGates st)) + +hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock +hBlock ifs env now peer eh body st = case frontReq st peer of + Just (ReqBody el eh' bs cs) | eh' == eh -> + let st1 = popFront peer st + closureBytes = sum (map txRefSize (bodyTxlist body)) + in if bodyEbHash body /= eh || bodyActualSize body /= bs || closureBytes /= cs + then pure (st1, [Disconnect peer BodyMismatch]) + else if not (wants st el eh) + then considerFetchAfter env now st1 [] + else do + let txrefs = bodyTxlist body + txhs = Set.fromList (map txRefHash txrefs) + hits <- txCacheOnBody (ifTxc ifs) eh txhs + memHs <- mempoolQueryPresent (ifMem ifs) (txhs `Set.difference` hashes hits) + txCacheOnAcquire (ifTxc ifs) memHs + let onHand = hashes hits `Set.union` hashes memHs + toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] + jobsMap = chunk env toFetch + copied = hits ++ memHs + writes = SubmitDisk (Write (WriteBody el body)) + : [ SubmitDisk (Write (WriteClosure el eh copied)) | not (null copied) ] + st2 = setTxs el eh jobsMap (fromIntegral (length writes)) st1 + considerFetchAfter env now st2 writes + _ -> pure (st, [Disconnect peer UnsolicitedResponse]) + +hBlockTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> [Tx] -> St -> m (St, [Effect]) -- BEH-Responses · §3 LevBlockTxs +hBlockTxs ifs env now peer eh txs st = case frontReq st peer of + Just (ReqJob el eh' j job) | eh' == eh -> + let st1 = popFront peer st + in if map txHash txs /= NE.toList (jobTxs job) + then pure (st1, [Disconnect peer TxsMismatch]) + else do + txCacheOnAcquire (ifTxc ifs) txs + let writes = [SubmitDisk (Write (WriteClosure el eh txs))] + case Map.lookup el (stWanted st1) of + Just (AwaitingTxs web t) | web == eh -> + let jobs' = Map.delete j (txsFetch t) + st2 = setTxs el eh jobs' (txsWrites t + 1) st1 + in considerFetchAfter env now st2 writes + _ -> considerFetchAfter env now st1 writes + _ -> pure (st, [Disconnect peer UnsolicitedResponse]) + +hServeBody :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockRequest +hServeBody ifs _env _now peer eh st = do + mbBody <- dbReadBody (ifDb ifs) eh + case mbBody of + Just body -> pure (st, [Send peer (MsgLeiosBlock eh body)]) + _ -> pure (st, [Disconnect peer RequestedAbsentData]) + +hServeTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> NonEmpty TxHash -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockTxsRequest +hServeTxs ifs _env _now peer eh txs st = do + served <- dbReadClosureTxs (ifDb ifs) eh (NE.toList txs) + if length served == NE.length txs + then pure (st, [Send peer (MsgLeiosBlockTxs eh served)]) + else pure (st, [Disconnect peer RequestedAbsentData]) + +hCertValidated :: Monad m => Ifaces m -> Env -> Time -> AnnouncementTriple -> ByteCount -> ByteCount -> St -> m (St, [Effect]) -- BEH-Wanting · BEH-FetchPriority · §3 LevCertValidated +hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st = do + let st1 = setCertified el (hh, eh) st + done <- isComplete ifs eh + let st2 | belowTip env el = st1 + | done = removeWant el st1 + | otherwise = ensureWantedBody st1 el eh bs cs + considerFetchAfter env now st2 [] + +hPeerAdd :: Monad m => Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd +hPeerAdd peer cls st = pure + ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) + , stPeerOfferings = Map.insert peer Map.empty (stPeerOfferings st) } + , [] ) + +hPeerWindDown :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerWindDown +hPeerWindDown env now peer st = + let st1 = st { stPeerPresent = Map.adjust (\pi_ -> pi_ { peerPhase = WindingDown }) peer (stPeerPresent st) } + in considerFetchAfter env now st1 [] + +hPeerRemove :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerRemove +hPeerRemove env now peer st = + let st1 = st { stPeerPresent = Map.delete peer (stPeerPresent st) + , stPeerFirstAnnouncements = Map.delete peer (stPeerFirstAnnouncements st) + , stPeerOfferings = Map.delete peer (stPeerOfferings st) + , stPeerOfferGates = Map.delete peer (stPeerOfferGates st) + , stPeerNotifyQueue = Map.delete peer (stPeerNotifyQueue st) + , stPeerInflight = Map.delete peer (stPeerInflight st) } + in considerFetchAfter env now st1 [] + +hTimer :: Monad m => Peer -> Req -> St -> m (St, [Effect]) -- BEH-Timeout · §3 LevTimer +hTimer peer req st = pure (st, [Disconnect peer RequestTimeout | inflightHas st peer req]) + +hDiskDone :: Monad m => Ifaces m -> Env -> Time -> DiskWrite -> St -> m (St, [Effect]) -- §3 LevDiskDone · BEH-Completion +hDiskDone _ifs _env _now w st = case w of + WriteBody el body -> let (st1, fx1) = enqueueBodyOffers el (bodyEbHash body) st + (st2, fx2) = decWrite el (bodyEbHash body) st1 + in pure (st2, fx1 ++ fx2) + WriteClosure el eh _ -> pure (decWrite el eh st) + +decWrite :: Election -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) +decWrite el eh st = case Map.lookup el (stWanted st) of + Just (AwaitingTxs eh' t) | eh' == eh -> case decTxsState t of + Just t' -> (setWant el (AwaitingTxs eh t') st, []) + Nothing -> let (st', fx) = enqueueClosureOffers el eh (removeWant el st) + in (st', NotifyVotingAndChainSel el eh : fx) + _ -> (st, []) + +hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced +hImmTipAdvanced env st = + let s = envImmutableTip env + st1 = pruneBelow s st + in pure (st1, [SubmitDisk (Promote s)]) + +hGarbageCollect :: Monad m => Slot -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevGarbageCollect +hGarbageCollect s st = pure (st, [SubmitDisk (GarbageCollect s)]) + +hSelfIssued :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> Body -> St -> m (St, [Effect]) -- BEH-SelfIssued · §3 LevSelfIssued +hSelfIssued ifs env now h body st = case rbAnnounce h of + Nothing -> pure (st, []) + Just ann -> do + (st1, fx) <- centralAnnounce ifs env now h st + let el = rbElection h + eh = annEbHash ann + txrefs = bodyTxlist body + txhs = Set.fromList (map txRefHash txrefs) + memHs <- mempoolQueryPresent (ifMem ifs) txhs + txCacheOnAcquire (ifTxc ifs) memHs + let onHand = hashes memHs + toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] + jobsMap = chunk env toFetch + copied = memHs + writes = SubmitDisk (Write (WriteBody el body)) + : [ SubmitDisk (Write (WriteClosure el eh copied)) | not (null copied) ] + st2 = setTxs el eh jobsMap (fromIntegral (length writes)) st1 + pure (st2, fx ++ writes) + +considerFetching :: Monad m => Env -> Time -> St -> m (St, [Effect]) -- §3 consider-fetching · NEEDS-TO-BE-INCREMENTAL: reconsider only the affected peer(s)/EB, not every Active peer +considerFetching env now st = pure (foldl' go (st, []) (activePeers st)) + where + go (s, fx) peer = + let new = decide env s peer + s' = foldl' (issue peer) s new + fx' = fx ++ concatMap (sendReq s now peer) new + in (s', fx') + +considerFetchAfter :: Monad m => Env -> Time -> St -> [Effect] -> m (St, [Effect]) +considerFetchAfter env now st fx = do + (st', fx') <- considerFetching env now st + pure (st', fx ++ fx') + +issue :: Peer -> St -> Req -> St +issue peer st r = + st { stPeerInflight = Map.insertWith (flip (<>)) peer (Seq.singleton r) (stPeerInflight st) } + +sendReq :: St -> Time -> Peer -> Req -> [Effect] +sendReq st now peer r = [Send peer (reqWire st r), SetTimer peer r now] + +reqWire :: St -> Req -> WireMsg +reqWire _ (ReqBody _ eh _ _) = MsgLeiosBlockRequest eh +reqWire _ (ReqJob _ eh _ job) = MsgLeiosBlockTxsRequest eh (jobTxs job) + +frontReq :: St -> Peer -> Maybe Req +frontReq st peer = case inflightOf st peer of + r :<| _ -> Just r + _ -> Nothing + +popFront :: Peer -> St -> St +popFront peer st = st { stPeerInflight = Map.adjust dropFront peer (stPeerInflight st) } + where dropFront sq = case sq of _ :<| rest -> rest; Empty -> Empty + +setWant :: Election -> WantState -> St -> St +setWant el ws st = st { stWanted = Map.insert el ws (stWanted st) } + +removeWant :: Election -> St -> St +removeWant el st = st { stWanted = Map.delete el (stWanted st) } + +isComplete :: Monad m => Ifaces m -> EbHash -> m Bool -- BEH-Completion (restart-time check only, in LevCertValidated) +isComplete ifs eh = do + mb <- dbReadBody (ifDb ifs) eh + case mb of + Nothing -> pure False + Just body -> do + let need = Set.insert (DbBody eh) (Set.fromList (map (DbClosureTx eh . txRefHash) (bodyTxlist body))) + have <- dbQueryPresent (ifDb ifs) need + pure (need `Set.isSubsetOf` have) + +setCertified :: Election -> (HeaderHash, EbHash) -> St -> St +setCertified el v st = st { stCertified = Map.insert el v (stCertified st) } + +ensureWantedBody :: St -> Election -> EbHash -> ByteCount -> ByteCount -> St +ensureWantedBody st el eh bs cs = case Map.lookup el (stWanted st) of + Just _ -> st + Nothing -> setWant el (AwaitingBody eh bs cs) st + +enqueueOffer :: Notification -> Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion · NEEDS-TO-BE-INCREMENTAL: (Election,EbHash)↦gated-downstream-peers index +enqueueOffer notif el eh st = + foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer notif s in (s', fx ++ fx')) (st, []) gated + where + gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), Map.lookup el gates == Just eh ] + +enqueueBodyOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion +enqueueBodyOffers el eh = enqueueOffer (NotifyBlockOffer el eh) el eh + +enqueueClosureOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion +enqueueClosureOffers el eh = enqueueOffer (NotifyBlockTxsOffer el eh) el eh + +pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete +pruneBelow s st = st + { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) + , stWanted = pruneElectionMap s (stWanted st) + , stCertified = pruneElectionMap s (stCertified st) + , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) + , stPeerOfferings = Map.map (pruneElectionMap s) (stPeerOfferings st) + , stPeerOfferGates = Map.map (pruneElectionMap s) (stPeerOfferGates st) + } + +pruneElectionMap :: Slot -> Map Election a -> Map Election a +pruneElectionMap s = Map.filterWithKey (\el _ -> not (electionSlot el < s)) + +advancePeerAnn :: Peer -> Election -> RbHeader -> St -> Maybe St -- §3 LevBlockAnnouncement per-peer check +advancePeerAnn peer el h st = + let perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)) + in case Map.lookup el perPeer of + Nothing -> Just (putSeen (SeenOne h)) + Just (SeenOne h1) + | rbHeaderHash h1 == rbHeaderHash h -> Nothing + | otherwise -> Just (putSeen (SeenTwo h1)) + Just (SeenTwo{}) -> Nothing + where + putSeen seen = st + { stPeerFirstAnnouncements = + Map.insert peer + (Map.insert el seen (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)))) + (stPeerFirstAnnouncements st) } + +centralAnnounce :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> St -> m (St, [Effect]) -- §3 LevBlockAnnouncement central branch +centralAnnounce _ifs env _now h st = case rbAnnounce h of + Nothing -> pure (st, []) + Just ann -> + let el = rbElection h + in case Map.lookup el (stFirstAnnouncements st) of + Nothing -> + let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } + st2 | belowTip env el = st1 + | otherwise = setWant el (AwaitingBody (annEbHash ann) (annBodySize ann) (annClosureSize ann)) st1 + in pure (enqueueToAll (NotifyAnnouncement h) st2) + Just (AnnOne h1) + | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) + | otherwise -> + let st1 = st { stFirstAnnouncements = Map.insert el (AnnTwo h1 h) (stFirstAnnouncements st) } + in pure (enqueueToAll (NotifyEquivProof (Just h1) h) st1) + Just (AnnTwo{}) -> pure (st, []) + +raiseOffer :: Peer -> NESet Election -> OfferSide -> St -> St -- §3 LevBlockOffer raise OfferSide +raiseOffer peer els lvl st = + st { stPeerOfferings = Map.insert peer updated (stPeerOfferings st) } + where + perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferings st)) + updated = foldr (\el m -> Map.insert el (raise (Map.lookup el m)) m) perPeer (toList (NESet.toSet els)) + raise Nothing = That lvl + raise (Just (This c)) = These c lvl + raise (Just (That l)) = That (max l lvl) + raise (Just (These c l)) = These c (max l lvl) + +nullIfaces :: Applicative m => Ifaces m +nullIfaces = Ifaces + { ifDb = LeiosDb { dbQueryPresent = const (pure Set.empty) + , dbReadBody = const (pure Nothing) + , dbReadClosureTxs = \_ _ -> pure [] } + , ifTxc = TxCache { txCacheNoteAnnouncement = const (pure ()) + , txCacheOnBody = \_ _ -> pure [] + , txCacheOnAcquire = const (pure ()) } + , ifMem = Mempool { mempoolQueryPresent = const (pure []) } + } + +prop_wantAnnouncementGated :: St -> Bool -- §4 Want is announcement-gated +prop_wantAnnouncementGated st = + Map.keysSet (stWanted st) + `Set.isSubsetOf` (Map.keysSet (stFirstAnnouncements st) `Set.union` Map.keysSet (stCertified st)) + +prop_perPeerActiveEbCap :: Env -> St -> Bool -- §4 Per-peer active-EB cap +prop_perPeerActiveEbCap env st = + all (\(peer, pinfo) -> Set.size (activeEbs st peer) <= maxActiveEbs env (peerClass pinfo)) + (Map.toList (stPeerPresent st)) + +prop_offersAnnouncedOrCertified :: St -> Bool -- §4 Offers are announced or certified +prop_offersAnnouncedOrCertified st = and + [ case side of + This _ -> True + These _ _ -> True + That _ -> isJust (firstAnnouncedEb st peer el) + | (peer, els) <- Map.toList (stPeerOfferings st) + , (el, side) <- Map.toList els ] + +prop_inflightOffered :: St -> Bool -- §4 Client soundness (offer half) +prop_inflightOffered st = and + [ case r of + ReqBody _ eh _ _ -> peer `Set.member` offerersBody st eh + ReqJob _ eh _ _ -> peer `Set.member` offerersClosure st eh + | (peer, sq) <- Map.toList (stPeerInflight st) + , r <- toList sq ] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md index 705fdb55df..9eeb7131f3 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md @@ -62,7 +62,7 @@ part is collected in the §6 appendix; it treats certs as first-class Leios mess also makes its EB wanted; **[SF]** when it names an EB other than our first-seen, the want switches to the certified EB — skew fallback (§6). -- **`BEH-Offers`** (client; availability). `LevBlockOffer(peer, ebHash)` / `LevBlockTxsOffer(peer, ebHash)` (LeiosNotify), +- **`BEH-Offers`** (client; availability). `LevBlockOffer(peer, election, ebHash)` / `LevBlockTxsOffer(peer, election, ebHash)` (LeiosNotify), `LevRollForward(peer, header)` (ChainSync; `header` announces `ebHash`): `peer` has `ebHash`'s body / full closure; a closure offer implies a body offer. Offers carry no size (sizes come from announcements). Junk-offer defense, judged per peer: a LeiosNotify offer is legitimate only for the first EB `peer` announced @@ -81,12 +81,22 @@ part is collected in the §6 appendix; it treats certs as first-class Leios mess - **`BEH-NotifyServe`** (server). Each downstream peer has a notification queue (`LstPeerNotifyQueue`) the node feeds as it receives announcements/certs and completes closures. A credit - (`MsgLeiosNotificationRequestNext`) from the peer raises the queue's capacity by one; the server - sends the highest-priority entry whenever the queue is non-empty and sending isn't otherwise - blocked. - The queue is back-pressure, not a buffer: its capacity is the peer's outstanding credits, and - producing into a full queue evicts the lowest-priority entry (which may be the new one). - Honest peers keep hundreds of credits outstanding, so their queues never fill. The shared + (`MsgLeiosNotificationRequestNext`) from the peer raises the queue's capacity by one; a server thread + sends the highest-priority entry whenever the queue is non-empty and the thread is ready to write. Those + readiness conditions (socket writable, thread scheduled) are out of model, so the send is driven by the + `LevNotifyDequeue` pseudo-stimulus (§2/§3), which arises only when the queue is non-empty — a credit grows the + window, it never itself triggers a send. + The queue is back-pressure, not a buffer: its capacity is the peer's outstanding credits — but bounded by + `notifyMaxCapacity`: a peer that credits past that bound is over-crediting and is disconnected, so it cannot + inflate its capacity without bound. Producing into a full queue evicts the lowest-priority entry (which may be the + new one). Honest peers keep hundreds of credits outstanding, so their queues never fill. + A dequeued notification whose EB is already below the immutable tip is stale and is discarded rather than sent + (the queue is not pruned on tip advance). Symmetrically, a peer that *sends* us a LeiosNotify message whose slot + is far below our immutable tip is disconnected: that is stale garbage, not honest diffusion. Every LeiosNotify + message carries at least one slot — the election slot of its announcement/offer/cert; for a message spanning + several elections (an `EbHash` offer can map to more than one), the youngest such slot. The recipient compares + that slot to its current immutable tip and reads the difference as a duration; if it exceeds `notifyStaleHorizon` + (≈ 10 minutes), disconnect. The shared `notifyPriority` rule (§2) is evaluated against the current `now` at each send and eviction — it is time-varying, so the queue keeps no stored order (§2). Relay, from the central state: the first announcement when it first arrives; on equivocation, an equivocation proof (carrying @@ -138,11 +148,12 @@ part is collected in the §6 appendix; it treats certs as first-class Leios mess instant the last part is in hand: either the last outstanding job's txs arriving (`LevBlockTxs`), or, when `BEH-ChunkJobs` finds the TxCache/Mempool already held everything, at chunk time (no jobs to await). Completion lands when those writes do (`LevDiskDone`). Fan out: immediately the fetch - side stops pursuing this EB; after the write lands, expose `ebHash`'s closure to the disk-reading - consumers — offering it to downstream peers (`BEH-NotifyServe`), voting, and notifying - ChainSel: it must be told that `ebHash`'s closure is now available (readable in the store), since it - may have a block whose adoption was waiting on exactly that closure, and the notification lets it - (re)process such a block (its acquired-set/reprocess machinery is out of the fetch core, §1 + side stops pursuing this EB. Once the body's write lands, offer the body to downstream peers (a body + offer). Once the closure's last write lands — making `ebHash` durably complete — expose its closure to the disk-reading + consumers — offering it to downstream peers (`BEH-NotifyServe`), and notifying voting and ChainSel together + (one `NotifyVotingAndChainSel`): they must be told that `ebHash`'s closure is now available (readable in the + store), since ChainSel may have a block whose adoption was waiting on exactly that closure, and the notification + lets it (re)process such a block (its acquired-set/reprocess machinery is out of the fetch core, §1 below). (persist-before-expose.) - **`BEH-FetchPriority`** (which EBs first). Certified EBs (a validated cert, via @@ -174,7 +185,7 @@ is connection-scoped — gone on shutdown, rebuilt as peers reconnect. - **`BEH-Shutdown`.** Flush outstanding store writes so every acquired body and tx (both EB closures and TxCache) (**[SF]** cert) is on disk, and persist the TxCache window (§7). Nothing else of Leios's own state is persisted. - **`BEH-Startup`.** Begin with empty per-peer state (peers (re)connect via `LevPeerAdd`); rebuild the TxCache - from its persisted window and GC it against the wall clock (§7) *before* pruning the store; prune everything below the current immutable tip (`BEH-TipAdvance`). The + from its persisted window and GC it against the wall clock (§7) *before* pruning the store; prune everything below the current immutable tip (`BEH-ImmTipAdvance`). The central want/cert/announce state (`LstWanted`/`LstCertified`/`LstFirstAnnouncements`) is re-derived, not persisted — ChainSel re-validates the CertRBs on our selected chain (re-emitting `LevCertValidated`) and re-delivers their announcements (`LevRollForward`), and gossiped-only @@ -200,9 +211,12 @@ is connection-scoped — gone on shutdown, rebuilt as peers reconnect. which is harmless (nothing is shared across peers). The graceful path is `LevPeerWindDown` then `LevPeerRemove` after the peer drains; an abrupt `LevPeerRemove` (the peer died) skips the wind-down. -- **`BEH-TipAdvance`** (immutable tip → slot `s`). Schedule disk GC (drop volatile data below the new tip) - and promote (copy the now-immutable data from volatile storage to the immutable store), then range-delete - every slot-indexed state variable below the tip. This GC imposes a constraint on almost all of the +- **`BEH-ImmTipAdvance`** (immutable tip → slot `s`). Promote promptly (copy the now-immutable data from volatile + storage to the immutable store) and range-delete every slot-indexed state variable below the tip. The disk GC + (drop volatile data below the new tip) is *delayed*, not prompt: like the ChainDB, the node lets a GC delay + elapse before dropping volatile data, so in-flight readers of soon-to-be-collected data are not cut off. The GC + is therefore a separate, harness-scheduled event (`LevGarbageCollect`, §3), not part of this advance. This prune + imposes a constraint on almost all of the state: each retained state variable must be slot-indexed so the prune is an index-accelerated range-delete `[.., s)`, never a scan. So the `Election`-keyed state variables — LeiosNotify `LstFirstAnnouncements`/`LstPeerFirstAnnouncements`/`LstPeerOfferings`/`LstPeerOfferGates` (**[SF]** §6's `LstAnnouncedCert`) and LeiosFetch @@ -228,18 +242,18 @@ is connection-scoped — gone on shutdown, rebuilt as peers reconnect. diffuses, is served, and is voted on like any other EB. (The issuer's internal logic — EB construction, sortition — is out of scope; this is just the hand-off into this document's machinery.) -**Out of the fetch core** (effect interfaces + boundary events): disk store; notifying ChainSel that -an EB closure is acquired (its acquired-set/reprocess machinery); GC/promote bodies; voting. The ChainSync↔Leios bridge is not +**Out of the fetch core** (effect interfaces + boundary events): disk store; notifying voting and ChainSel that +an EB closure is acquired (ChainSel's acquired-set/reprocess machinery); GC/promote bodies; voting. The ChainSync↔Leios bridge is not modeled here. A ChainSync `MsgRollForward` delivers one RB `header`; the bridge echoes it as the stimulus -`LevRollForward(peer, header, predEb)`, enriching the wire payload with the predecessor's announced-EB -identity (`predEb` — just the relevant parts: its `HeaderHash`, EB hash, and election, from the preceding `HeaderState`) +`LevRollForward(peer, header, predEb)`, enriching the wire payload with the predecessor's announcement +triple (`predEb` — the announced-EB identity: its election, `HeaderHash`, and EB hash, from the preceding `HeaderState`) — needed because the cert-bit case below certifies the EB the predecessor announced, which `header` alone does not provide. Regardless of its cert bit, `header` announces the RB's own EB `ebHash` (`BEH-Wanting`), updating the central `LstFirstAnnouncements` but not `LstPeerFirstAnnouncements`, which is specific to LeiosNotify. When the cert bit is set, the RB's body certifies the earlier EB `ebHash′` that `predEb` identifies: the peer offers `ebHash′`'s body+closure (`BEH-Offers`, a backstop to LeiosNotify), and — separately — ChainSel validates that cert on first -processing the CertRB and emits `LevCertValidated(headerHash′, ebHash′)`, which makes `ebHash′` +processing the CertRB and emits `LevCertValidated(el′, headerHash′, ebHash′, bodySize′, closureSize′)`, which makes `ebHash′` wanted. **[SF]** §6's `BEH-CertFetch` is the other emitter of `LevCertValidated`, from a cert offered via `LevCertOffer`. @@ -254,8 +268,8 @@ LeiosNotify: the first accepted announcement, plus the first equivocation, if any, once seen; in `Two` the left header is by convention the older, first-announced one. Drives `BEH-Wanting` and the server relay `BEH-NotifyServe`. -- `LstPeerFirstAnnouncements : Peer ↦ Election ↦ AnnSeen`, `AnnSeen = One HeaderHash | Two HeaderHash` — the ≤2 - announcement headers this peer sent; the ≤2 bound and equivocation-disconnect derive from it. +- `LstPeerFirstAnnouncements : Peer ↦ Election ↦ AnnSeen`, `AnnSeen = One RbHeader | Two RbHeader` — the peer's + first-announced header for the election (and, via the `One`/`Two` tag, whether it has since equivocated); the ≤2 bound and equivocation-disconnect derive from it. (**[SF]** §6: a peer's cert assertion lives in `LstPeerOfferings`'s `CertSide`.) - `LstPeerOfferings : Peer ↦ Election ↦ These CertSide OfferSide` — availability; `These` makes the all-empty entry simply absence, with no meaningless empty record. `OfferSide = Body | @@ -272,7 +286,7 @@ LeiosNotify: It does not gate announcement-sending — `LstFirstAnnouncements` already does that; `BEH-NotifyServe` skips an EB offer if its gate here isn't yet open. - `LstPeerNotifyQueue : Peer ↦ Set Notification` — per-downstream-peer pending notifications; capacity = - that peer's outstanding credits. Because `notifyPriority` depends on `now` (§ Helper functions), there is + that peer's outstanding credits, bounded by `notifyMaxCapacity`. Because `notifyPriority` depends on `now` (§ Helper functions), there is no fixed order to store and keep sorted: it is an unordered set, and priority is evaluated at the only two moments it is consulted — sending removes the `notifyPriority(now, ·)`-max, and producing into a full set evicts the `notifyPriority(now, ·)`-min (which may be the entry just produced). The order between two @@ -284,17 +298,23 @@ LeiosFetch: GC range-deletes on the slot-major key. An election enters via its first `LevBlockAnnouncement` or via a validated cert (`LevCertValidated`), so `dom(LstWanted) ⊆ dom(LstFirstAnnouncements) ∪ dom(LstCertified)`. `WantState = AwaitingBody { ebHash, bodySize, closureSize } | - AwaitingTxs { ebHash, closureSize, jobs : NonEmpty (JobId ↦ Job) }` — `ebHash : EbHash` names which EB of the + AwaitingTxs { ebHash, outstanding }` — `ebHash : EbHash` names which EB of the election is wanted (**[SF]** a cert can switch it in place). Over all of time, `LstWanted[el].ebHash` takes at most two distinct values, because its two insertion sources each name one: the first announcement names its EB (later, different-EB announcements are equivocations, never wanted), and a validated cert names the certified EB (at most one EB per election is certifiable, by honest-majority anti-equivocation). They coincide in the baseline; **[SF]** skew is the only way the cert's EB differs from the first-announced. - `AwaitingTxs.jobs` holds only the - outstanding jobs (a job is removed once its `LevBlockTxs` arrives) and is non-empty: when the last job's - response would empty it, `complete(el)` runs and removes the `el` entry instead, so an `AwaitingTxs` never - rests with no jobs. `Job = { txs : NonEmptySet TxHash }`, txs fixed at chunk time (§5 would shrink it as + `outstanding = These (JobId ↦ Job) ℕ` pairs the jobs still awaiting a `LevBlockTxs` response with + `outstandingWrites − 1` — the count of this EB's disk writes (its body, its TxCache/Mempool-hit copy, and + one per fetched job) that have not yet reported `LevDiskDone`. The `These` is non-empty by construction, so + the `el` entry exists exactly while the closure is still being fetched or persisted. A job leaves the fetch + side once its `LevBlockTxs` arrives — at which point a closure write for it is scheduled, so + `outstandingWrites` rises. `complete(el)` (fetch side now empty) emits **nothing** and does **not** delete the + entry — writes remain outstanding, and the consumers (voting reads the body+closure from disk, ChainSel + reprocesses, downstream peers serve) all read the persisted closure, so the whole fan-out is persist-gated. The + entry is cleared, and that fan-out released, only by the `LevDiskDone` that lands the last write + (`outstandingWrites` reaching zero with the fetch side already empty) — `BEH-Completion`. `Job = { txs : NonEmpty TxHash }` (an ordered, non-empty list, in the body's tx order), txs fixed at chunk time (§5 would shrink it as constituent txs arrive by other means). Cached txs (`BEH-ChunkJobs`) never become jobs, so they are implicitly on hand. - `LstCertified : Election ↦ (HeaderHash, EbHash)` — validated cert per election (grown by `LevCertValidated`): @@ -307,14 +327,16 @@ LeiosFetch: + `≤128`-announcement window, membership, two-trigger eviction, separate backing store, and persistence are all isolated in §7; the main spec only calls its hooks (`txCacheNoteAnnouncement` / `txCacheOnBody` / `txCacheOnAcquire` / `dbCopyFromTxCache`). -- `LstPeerInflight : Peer ↦ Seq Req` (a FIFO), `Req = ReqBody Election EbHash | ReqJob Election EbHash JobId` - **[SF]** `| ReqCert Election HeaderHash` (a cert binds to an announcement, so it is keyed by `HeaderHash`, not `EbHash`) — the LeiosFetch protocol delivers replies in request-issue order +- `LstPeerInflight : Peer ↦ Seq Req` (a FIFO), `Req = ReqBody { el, ebHash, bodySize, closureSize } | ReqJob { el, ebHash, jobId, job }` + **[SF]** `| ReqCert { el, headerHash }` (a cert binds to an announcement, so it is keyed by `HeaderHash`, not `EbHash`); each request also carries the data its reply is checked against — `ReqBody`'s announced `bodySize` and `closureSize`, `ReqJob`'s `job` (its txs and their summed size) — filled in from the want when the request is issued, so the §3 fetch rules below name a request by its `el`/`ebHash`/`jobId` identity. The LeiosFetch protocol delivers replies in request-issue order (at least today), so a response matches the front of the sequence, which is popped and used to validate it, never against current `LstWanted`: if the want moved on after we sent the request (cert switch, tip advance), the peer's reply is still valid, and it's our doing — not the peer's — that we no longer want it, so we drop the result without - disconnecting. The `Election` is carried only so the handler can advance `LstWanted[el]` (a write) in - O(log n). Each `Req` is tagged with its issue time (for `BEH-Timeout`). Not slot-GC'd — reclaimed by a + disconnecting. Conversely, a reply that matches no front entry — unsolicited, or out of request-issue + order — is adversarial: `disconnectFrom(peer)`. The `el` is carried only so the handler can advance `LstWanted[el]` (a write) in + O(log n). The timeout is not stored here: issuing a `Req` sets a per-request timer (`SetTimer peer req now`, + fired as `LevTimer`, `BEH-Timeout`), so the entry need carry no time of its own. Not slot-GC'd — reclaimed by a matching response, or by `LevPeerRemove` (which a `BEH-Timeout` triggers, via `disconnectFrom`); the §5 stagger clock is EB age, not this. Shared: @@ -328,11 +350,11 @@ Shared: LeiosNotify: - `electionOf : Peer ↦ EbHash ↦ NonEmptySet Election` — per peer, the elections for which `peer` - (first-)announced (**[SF]** or cert-asserted) an EB hashing to `ebHash`. The offer-ingestion index: a + first-announced (**[SF]** or cert-asserted) an EB hashing to `ebHash`. The offer-ingestion index: a bare-`ebHash` offer is *validated* by `electionOf[peer][ebHash]` being non-empty (else junk ⇒ disconnect) and *recorded* into `LstPeerOfferings[peer][el]` for each `el` in that set — the body/closure is content-addressed, so holding it serves every election that peer named it for. A derived cache of - `LstPeerFirstAnnouncements` (+ the headers it references), GC'd in lockstep: as an election ages below the + `LstPeerFirstAnnouncements`, GC'd in lockstep: as an election ages below the immutable tip and is range-deleted there, it is removed from its first-announced `ebHash`'s set, and the `ebHash` key disappears when the set empties (`NonEmptySet ⇒ absence`). This is the one place a bare `EbHash` is mapped back to an `Election`. @@ -346,9 +368,9 @@ LeiosNotify: (an EB with no offerers is simply absent — no empty value rests in the index). LeiosFetch: -- `jobInflightPeers(ebHash, j) = |{ peer | ReqJob _ ebHash j ∈ LstPeerInflight[peer] }|` (job-level rarest-first + §5 stagger) +- `jobInflightPeers(ebHash, j) = |{ peer | ReqJob _ ebHash j _ ∈ LstPeerInflight[peer] }|` (job-level rarest-first + §5 stagger) - `activeEbs(peer) = |{ ebHash | some Req for ebHash ∈ LstPeerInflight[peer] }|` (per-peer active-EB cap, §3) -- `peerSharingInFlightBytes(peer, ebHash) = Σ job sizes for ReqJob _ ebHash _ ∈ LstPeerInflight[peer]` (PeerSharing peers' ~1 MB limit) +- `peerSharingInFlightBytes(peer, ebHash) = Σ size(job) for ReqJob _ ebHash _ job ∈ LstPeerInflight[peer]` (PeerSharing peers' ~1 MB limit) - (There is no reverse `tx ↦ {EB}` index, because cross-EB membership is deliberately not tracked; `BEH-ChunkJobs`/`BEH-Responses`.) Discipline. Nothing in this section is stored — it is all recomputed from the genuine core on demand. The @@ -366,13 +388,22 @@ writes the core. So the spec stays simple now, and the optimized implementation Because the tiering is relative to `now`, the order slides as the clock advances — a fresh announcement outranks a bottom-tier cert now, yet once it ages past `3·L_hdr` the higher-slot cert overtakes it — so it is recomputed per comparison rather than cached, and any `notifyPriority`-ranked collection (e.g. - `LstPeerNotifyQueue`) is consulted only when acting, never via a stored order. Shared by the + `LstPeerNotifyQueue`) is consulted only when acting, never via a single stored total order. Shared by the `LstPeerNotifyQueue` dequeuer and every enqueuer (`BEH-NotifyServe`). + **Aside.** No *single* total order can be stored, but an implementation can still avoid the per-comparison + scan by keeping *two* slot-ordered queues per peer — one of announcements, one of the rest (certs/offers/votes). + The within-tier order is slot order, which is static; only the two tier cut-points (`now − L_hdr`, + `now − 3·L_hdr`) slide. So dequeue-max is O(1): the highest-slot announcement wins if it is younger than + `3·L_hdr` (it heads the `L_hdr` or `3·L_hdr` tier), otherwise every announcement has fallen into the bottom + tier and the max is the higher-slot of the two queue heads. The full-queue eviction is the symmetric pop-min. + ### Behind the disk store interface (dumb; shared) -`dbWriteBody` · `dbWriteTxsIntoClosure` · **[SF]** `dbWriteCert` · `dbQueryPresent(keys)` (which of those -bodies/txs/**[SF]** certs the store holds) · `dbGarbageCollect(slot)` · `dbPromote(point)` — presence facts +the writes `dbWriteBody(body)` · `dbWriteTxsIntoClosure(ebHash, txs)` · **[SF]** `dbWriteCert(cert)` (each +reports its durability back as a `LevDiskDone`); `dbQueryPresent(keys)` (which of those +bodies/txs/**[SF]** certs the store holds); and the maintenance ops `dbGarbageCollect(slot)` · `dbPromote(point)` +(fire-and-forget, no `LevDiskDone`) — presence facts only; no EB↔tx knowledge, no completion, no broadcast, so the logic composes EB-completeness (body present ∧ all closure txs present) from these. The TxCache is a separate component (§7); the main spec reaches it only through its hooks, and `dbCopyFromTxCache(txs)` (in `BEH-ChunkJobs`) copies cache hits into the closure. @@ -391,7 +422,10 @@ messages; unlike `Lst…` state, we neither own nor GC it. `jobSize` (~64–128 kB) · `peerSharingClosureByteLimit` (~1 MB) · `peerSharingLowWater`/`peerSharingHighWater` · `requestTimeout` (generous, ≈ BlockFetch) · `frontSkew` (job-ordering bias, see §3 Job ordering) · `L_hdr` (Leios header-diffusion window; `notifyPriority` tiers) · `stakeMaxActiveEbs` (~5) · -`peerSharingMaxActiveEbs` (~1–3) (per-peer active-EB cap). §5 (anticipated): `staggerPeers` (~1–2) · `staggerDelay` (~1–2 s). +`peerSharingMaxActiveEbs` (~1–3) (per-peer active-EB cap) · `notifyMaxCapacity` (~300) (upper bound on a peer's +notification-queue capacity, so a peer cannot inflate it without bound) · `notifyStaleHorizon` (~10 min, as a +slot difference) (a LeiosNotify message whose slot is more than this below the immutable tip is stale garbage → +disconnect). §5 (anticipated): `staggerPeers` (~1–2) · `staggerDelay` (~1–2 s). ### Messages and stimuli @@ -401,7 +435,8 @@ messages; unlike `Lst…` state, we neither own nor GC it. - `MsgLeiosNotificationRequestNext` - `MsgLeiosBlockAnnouncement(header)` - `MsgLeiosBlockEquivocationProof(header₁?, header₂)` - - `MsgLeiosBlockOffer(ebHash)` / `MsgLeiosBlockTxsOffer(ebHash)` + - `MsgLeiosBlockOffer(election, ebHash)` / `MsgLeiosBlockTxsOffer(election, ebHash)` — the offer carries the + announcing election alongside the `ebHash` (see the cross-election dedup TODO in §5) - **[SF]** `MsgLeiosCertOffer(header)` - LeiosFetch: - `MsgLeiosBlockRequest(ebHash)` / `MsgLeiosBlock(ebHash, body)` @@ -410,9 +445,9 @@ messages; unlike `Lst…` state, we neither own nor GC it. - ChainSync: - `MsgRollForward(header)` merely echoed from ChainSync, not directly received by Leios logic -`MsgLeiosBlockTxsRequest(ebHash, txs)` carries the requested job's tx hashes — +`MsgLeiosBlockTxsRequest(ebHash, txs)` carries the requested job's tx hashes in the job's order — the `jobId` is the client's own handle and never goes on the wire — and the matching `MsgLeiosBlockTxs(ebHash, txs)` -carries those txs, paired to the outstanding `ReqJob` by FIFO order (§2). (TODO: since both ends already +carries those txs in that same order, paired to the outstanding `ReqJob` by FIFO order (§2). (TODO: since both ends already hold `ebHash`'s body, they agree on `txset(ebHash)` and an ordering of it, so `MsgLeiosBlockTxsRequest`'s `txs` could be a compact intset/bitfield over that index rather than full tx hashes.) @@ -424,17 +459,27 @@ intset/bitfield over that index rather than full tx hashes.) announced, which `header` alone does not identify. So the bridge enriches the stimulus with that EB's identity — just the relevant parts (EB hash + election), from the preceding `HeaderState`: `LevRollForward(peer, header, predEb)` (see §3). -- `LevCertValidated(headerHash, ebHash)` ChainSel validated a CertRB's cert (`headerHash` = the certified -announcement, `ebHash` = the EB it announced); peerless, deduped by election — at most +- `LevCertValidated(el, headerHash, ebHash, bodySize, closureSize)` ChainSel validated a CertRB's cert; the payload is the certified +EB's announcement triple (election `el`, certified announcement `headerHash`, EB hash `ebHash`) — the same +announced-EB identity `LevRollForward` carries as `predEb` — plus the EB's announced `bodySize` and `closureSize`; peerless, deduped by election — at most once per election; updates `LstCertified[el]`/`LstWanted[el]`) - `LevPeerAdd(peer, class)` - `LevPeerWindDown(peer)` - `LevPeerRemove(peer)` -- `LevTimer(timeout, req)` -- `LevDiskDone(op)` +- `LevTimer(timeout, peer, req)` +- `LevDiskDone(w)` (`w` a `DiskWrite`; GC/promote do not report) - `LevImmTipAdvanced(slot)` +- `LevGarbageCollect(slot)` a pseudo-stimulus: the delayed disk GC for a slot that became immutable a GC delay + ago. The delay is the ChainDB's concern (the immutable tip is ChainDB-owned, harness-updated), so the harness + raises this `slot`'s GC after that delay — distinct from the prompt `LevImmTipAdvanced` promote. - `LevSelfIssued(header, body)` an EB this node created, see `BEH-SelfIssued` -- (§5) `LevTimer(staggerDelay, req)`. +- `LevNotifyDequeue(peer)` a pseudo-stimulus: a downstream notification server thread's send opportunity. Its + readiness conditions (socket writable, thread scheduled) are out of model, so the bridge raises it; it arises + only when the queue is non-empty, and the rule (§3) then ships one queued notification (or, if it is stale — + below the immutable tip — discards it without sending). Separate from the `LevNotificationRequestNext` credit so + that credit-arrival and send-timing are not conflated; the harness keeps the queue's occupancy via the + `NotifyEnqueue` action and this event (its inverse). +- (§5) `LevTimer(staggerDelay, peer, req)`. **Actions**. Outbound effects are inlined in the rules (no separate action vocabulary). Issuing a request = send the wire @@ -442,7 +487,9 @@ request (`MsgLeiosBlockRequest` / `MsgLeiosBlockTxsRequest` / **[SF]** `MsgLeios record the matching `Req…` in `LstPeerInflight[peer]`. Others: serve the response (`MsgLeiosBlock` / `MsgLeiosBlockTxs` / **[SF]** `MsgLeiosCert`, the same message a client receives from upstream); relay a `MsgLeiosBlockAnnouncement` / `MsgLeiosBlockEquivocationProof` / **[SF]** `MsgLeiosCertOffer`; schedule `dbWriteBody`/`dbWriteTxsIntoClosure`/**[SF]** `dbWriteCert`/`dbCopyFromTxCache`; `disconnectFrom(peer)`; schedule -`dbGarbageCollect`/`dbPromote`; set a timer; update state; emit closure-complete. +`dbGarbageCollect`/`dbPromote`; set a timer; update state; notify voting and ChainSel; enqueue a notification into +a downstream peer's queue (`NotifyEnqueue(peer)` — emitted whenever an enqueue grows the queue's occupancy, so the +harness can mirror it; the `LevNotifyDequeue` send is its inverse). --- @@ -450,24 +497,33 @@ record the matching `Req…` in `LstPeerInflight[peer]`. Others: serve the respo All updates within a rule are one atomic step. "consider fetching" = run the class-aware LeiosFetch decision (below). `complete(el)` is an impure helper (not a stimulus), invoked synchronously by -`LevBlock`/`LevBlockTxs` once `el`'s body is present and no jobs remain: let `ebHash = LstWanted[el].ebHash`; -remove `el` from `LstWanted`; emit closure-complete; defer the disk-reading fan-out until the relevant -`LevDiskDone` (persist-before-expose) — once the write lands, that fan-out enqueues a closure offer into -`LstPeerNotifyQueue[d]` for each downstream `d` with `LstPeerOfferGates[d][el] = ebHash`. A request is only issued to `peer` if `LstPeerPresent[peer]` exists with `phase = Active`. Offers update -`LstPeerOfferings[peer][el]` (each `el ∈ electionOf[peer][ebHash]`) per the `These` state machine (§2): `LevBlockOffer`/`LevBlockTxsOffer` raise -the first-announced EB's `OfferSide`; `LevRollForward` records `CertSide` and `BodyAndClosure`. +`LevBlock`/`LevBlockTxs` once `el`'s fetch side empties (no jobs remain): it merely records that fetch is done — +it emits nothing and does **not** remove `el` from `LstWanted`, since writes are still outstanding +(`AwaitingTxs.outstanding`, §2). The entry is cleared, and the whole disk-reading fan-out (the combined +voting + ChainSel notification, and the downstream closure offer) released, by the `LevDiskDone` that lands the +last write (persist-before-expose). A request is only issued to `peer` if `LstPeerPresent[peer]` exists with `phase = Active`. Offers update +`LstPeerOfferings[peer][el]` per the `These` state machine (§2): `LevBlockOffer`/`LevBlockTxsOffer` raise +the `OfferSide` at the offer's own `election` (which must be one the peer first-announced `ebHash` under); +`LevRollForward` records `CertSide` and `BodyAndClosure`. (**[SF]** §6's `LevCertOffer` also writes `CertSide`.) ### LeiosNotify rules +- **Staleness precondition (all inbound LeiosNotify messages)**: before handling any announcement / equivocation + proof / offer / cert from `peer`, take the message's slot — the election slot it carries, or, for a message + spanning several elections (an `EbHash` offer resolves through `electionOf[peer]` to one or more), the youngest + of those slots. If the immutable tip exceeds it by more than `notifyStaleHorizon` (the slot difference read as a + duration, ≈ 10 min), the message is stale garbage ⇒ `disconnectFrom(peer)`; otherwise handle it as below. (A + credit, `LevNotificationRequestNext`, carries no slot and is exempt.) + - **`LevBlockAnnouncement(peer, header)`**: validate `header` (signature/KES, etc.; invalid ⇒ `disconnectFrom(peer)`), and it must announce an EB (a LeiosNotify header that announces none is junk ⇒ `disconnectFrom(peer)`); let `ebHash`/`bodySize`/`closureSize` be its fields, `el = election(header)`, `h` = its `HeaderHash`. Per-peer check on `LstPeerFirstAnnouncements[peer][el]` (LeiosNotify only; a ChainSync `LevRollForward` skips - it): absent → `One h`; `One h` (same) → duplicate ⇒ - `disconnectFrom(peer)`; `One h₁` (`h ≠ h₁`) → `Two h₁`; `Two _` (or any third distinct header) → + it): absent → `One header`; recorded `One header₁` with `h = h₁` → duplicate ⇒ + `disconnectFrom(peer)`; `One header₁` with `h ≠ h₁` → `Two header₁`; `Two _` (or any third distinct header) → `disconnectFrom(peer)`. If accepted, note it to the TxCache (`txCacheNoteAnnouncement(ebHash)`, §7) and update central `LstFirstAnnouncements[el]`: absent → `One header`, and if `ebHash` is not complete nor below the immutable tip `LstWanted[el] = AwaitingBody{ ebHash, bodySize, closureSize }`, then enqueue the - announcement into every downstream `LstPeerNotifyQueue` and consider fetching; `One` → `Two` (different + announcement into every downstream `LstPeerNotifyQueue` (no fetch here — an announcement is not an offer); `One` → `Two` (different header) → record the equivocation, enqueue the equivocation proof downstream (**[SF]** §6 suppresses this once the election is certified); already `Two` → nothing further. An equivocating `ebHash` is never wanted (**[SF]** until/unless certified, §6). @@ -476,22 +532,23 @@ the first-announced EB's `OfferSide`; `LevRollForward` records `CertSide` and `B already sent us the first; `ebHashᵢ`/`hᵢ` are each header's EB / `HeaderHash`): validate it is a genuine equivocation — both headers validly signed (signature/KES, etc.), each announcing an EB, for the same election with `h₁ ≠ h₂` (using `header₁` if present else our recorded first - `LstPeerFirstAnnouncements[peer][el] = One h₁`; if neither, or if a header announces no EB, `disconnectFrom(peer)`). Advance `LstPeerFirstAnnouncements[peer][el]` to `Two` (inconsistent / already-`Two` + `LstPeerFirstAnnouncements[peer][el] = One header₁`; if neither, or if a header announces no EB, `disconnectFrom(peer)`). Advance `LstPeerFirstAnnouncements[peer][el]` to `Two` (inconsistent / already-`Two` with other headers → `disconnectFrom(peer)`). If `LstFirstAnnouncements[el]` is not yet `Two`, record the equivocation and enqueue the proof downstream (**[SF]** §6 suppresses this once the election is certified). If it was absent the proof carries `header₁` (else validation above disconnected): set `Two h₁ h₂` (left `h₁` = `ebHash₁`, the older, first-announced winner) and make `ebHash₁` wanted just as `LevBlockAnnouncement`'s `One` branch — gated - on `ebHash₁` being neither complete nor below the immutable tip. If it was `One h₁`, `ebHash₁` is already the + on `ebHash₁` being neither complete nor below the immutable tip. If it was `One header₁`, `ebHash₁` is already the recorded, wanted first; just advance to `Two`. The equivocating `ebHash₂` is never wanted. -- **`LevBlockOffer(peer, ebHash)`** (LeiosNotify): `ebHash` must be one `peer` (first-)announced — i.e. `electionOf[peer][ebHash]` - is non-empty (anything else, e.g. an EB `peer` only relayed as an equivocation, ⇒ `disconnectFrom(peer)`). - Raise the `OfferSide` to at least `Body` in `LstPeerOfferings[peer][el]` for each `el ∈ electionOf[peer][ebHash]`. - Consider fetching if `ebHash` is wanted. No `LstWanted` creation, no size. (**[SF]** §6 also admits `peer`'s cert-asserted EB and its precedence +- **`LevBlockOffer(peer, election, ebHash)`** (LeiosNotify): `peer` must have first-announced `ebHash` under + `election` (`LstPeerFirstAnnouncements[peer][election]`'s first-announcement names `ebHash`; an election `peer` + never announced, a mismatched `ebHash`, or an EB it only relayed as an equivocation ⇒ `disconnectFrom(peer)`). + Raise the `OfferSide` to at least `Body` in `LstPeerOfferings[peer][election]`. Consider fetching if `ebHash` is + wanted. No `LstWanted` creation, no size. (**[SF]** §6 also admits `peer`'s cert-asserted EB and its precedence over the first-announced.) -- **`LevBlockTxsOffer(peer, ebHash)`** (LeiosNotify; implies a body offer): same `electionOf[peer][ebHash]` check; set - `OfferSide = BodyAndClosure` at each such `el`. Consider fetching if `ebHash` is wanted. +- **`LevBlockTxsOffer(peer, election, ebHash)`** (LeiosNotify; implies a body offer): same first-announced check; + set `OfferSide = BodyAndClosure` at `LstPeerOfferings[peer][election]`. Consider fetching if `ebHash` is wanted. - **`LevRollForward(peer, header, predEb)`** (ChainSync): if `header` announces an EB `ebHash` (unlike LeiosNotify, a non-announcing chain header is a normal block — no disconnect, just no announcement effect), @@ -499,11 +556,11 @@ the first-announced EB's `OfferSide`; `LevRollForward` records `CertSide` and `B the central `LstFirstAnnouncements[election(header)]` exactly as `LevBlockAnnouncement`'s central branch (set `LstWanted`, relay, detect equivocation) — but never `LstPeerFirstAnnouncements` (chain relay is exempt from the per-peer ≤2 bound). This holds regardless of the cert bit. If the cert bit is set, the RB's body certifies the - earlier EB `ebHash′` that its predecessor announced — given by `predEb`, the predecessor's announced-EB identity - (its `HeaderHash` `headerHash′`, EB hash `ebHash′`, and election `el′`) from the preceding `HeaderState`, which the wire `MsgRollForward(header)` does not + earlier EB `ebHash′` that its predecessor announced — given by `predEb`, the predecessor's announcement triple + (its election `el′`, `HeaderHash` `headerHash′`, and EB hash `ebHash′`) from the preceding `HeaderState`, which the wire `MsgRollForward(header)` does not carry (hence the enriched stimulus, §2): record `peer`'s body+closure offer of `ebHash′` in `LstPeerOfferings[peer][el′]` - (`These (Cert headerHash′ ebHash′ _) BodyAndClosure`, latest wins). ChainSel validates that cert and emits `LevCertValidated(headerHash′, ebHash′)`. + (`These (Cert headerHash′ ebHash′ _) BodyAndClosure`, latest wins). ChainSel validates that cert and emits `LevCertValidated(el′, headerHash′, ebHash′, bodySize′, closureSize′)`. Cert-conflict disconnect: if `LstCertified[el′]` is already set with a `HeaderHash` other than `headerHash′`, this peer is offering a cert that cannot exist ⇒ `disconnectFrom(peer)`. Consider fetching. (**[SF]** §6: `ebHash′`'s offer takes precedence over a LeiosNotify offer for the @@ -511,10 +568,23 @@ the first-announced EB's `OfferSide`; `LevRollForward` records `CertSide` and `B lack it, subject to the preferable-header suppression TODO there; and the cert-conflict disconnect above extends to the `LevCertOffer` vehicle.) -- **`LevNotificationRequestNext(peer)`**: raises `LstPeerNotifyQueue[peer]`'s capacity by one; if non-empty, dequeue - the highest-priority notification (`notifyPriority`) and send it. Sending an announcement for `ebHash` - opens its gate (`LstPeerOfferGates[peer][el] := ebHash`), then consider offering that EB to `peer` if its - artifact is stored. (**[SF]** §6: sending a `MsgLeiosCertOffer` pivots `peer`'s gate — drop the superseded announced EB for that election from `LstPeerOfferGates[peer]`, add the certified EB.) +- **`LevNotificationRequestNext(peer)`**: a credit — raises `LstPeerNotifyQueue[peer]`'s capacity by one. If that + would exceed `notifyMaxCapacity`, `peer` is over-crediting (extending more outstanding credits than the bound + permits) — disconnect instead of accruing it, so a peer cannot inflate its capacity without bound. The send itself + happens on `LevNotifyDequeue` (below); a credit only grows the window. Capacity is the credit's sole role: with no + capacity nothing can be enqueued, so a non-empty queue already witnesses an outstanding credit. + +- **`LevNotifyDequeue(peer)`**: a send opportunity for `peer`'s downstream notification server thread, whose + readiness conditions — socket writable, thread scheduled — are out of model, so the bridge raises this. It arises + only when `LstPeerNotifyQueue[peer]` is non-empty (the harness tracks occupancy via `NotifyEnqueue` and this + event): dequeue the highest-priority notification (`notifyPriority`). If its EB's slot is below the immutable tip + it is stale — the EB is already settled, and the queue is *not* pruned on `LevImmTipAdvance` (it is not slot-major + range-deletable) — so discard it without sending and without consuming a credit. Otherwise send it and consume + one credit. Sending an + announcement for `ebHash` opens its gate (`LstPeerOfferGates[peer][el] := ebHash`) — and nothing more: an EB is + offered to `peer` only if its gate was already open when the artifact completed, never by re-checking a backlog + here. (**[SF]** §6: sending a `MsgLeiosCertOffer` pivots `peer`'s gate — drop the superseded announced EB for that + election from `LstPeerOfferGates[peer]`, add the certified EB.) ### LeiosFetch rules @@ -540,8 +610,8 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere LstPeerInflight[peer]`. No per-EB multiplicity cap and no cross-peer check — every offerer is asked independently (the active-EB cap above bounds the distinct EBs per peer, not the offerers per EB). - Stake closure — for a `StakeSampled` `peer ∈ offerersClosure(ebHash)` with `LstWanted[el] = AwaitingTxs`: - issue `ReqJob el ebHash j` to `peer` for each still-outstanding job `j ∈ LstWanted[el].jobs` with - `(peer, ReqJob el ebHash j) ∉ LstPeerInflight[peer]`. No per-EB job cap. Its only shared input is `LstWanted[el].jobs` + issue `ReqJob el ebHash j` to `peer` for each job `j` still on `LstWanted[el].outstanding`'s fetch side with + `(peer, ReqJob el ebHash j) ∉ LstPeerInflight[peer]`. No per-EB job cap. Its only shared input is that fetch side (which any peer's response shrinks) — central want-state, not another peer's state. - PeerShare closure — for a `PeerSharingSampled` `peer ∈ offerersClosure(ebHash)`: while `peerSharingInFlightBytes(peer, ebHash) < peerSharingClosureByteLimit`, pick a still-outstanding job not already in-flight @@ -555,28 +625,35 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere - (§5, not yet) Staggered requesting adds the second cross-peer coupling — while an EB is young, hold each of its items to ≤ `staggerPeers` peers (again reading cross-peer in-flight). -- **`LevBlock(peer, ebHash, body)`**: the front of `LstPeerInflight[peer]` must be `ReqBody _ ebHash` (§2; drop if not); let `el` - be its election. Validate hash = `ebHash` and actual size against `ebHash`'s announced `bodySize` (from - the request, not `LstWanted`); on mismatch drop (adversarial). Else, if `LstWanted[el]` still wants `ebHash`: `scheduleDisk dbWriteBody`, then `BEH-ChunkJobs` — `txCacheOnBody` +- **`LevBlock(peer, ebHash, body)`**: the front of `LstPeerInflight[peer]` must be a `ReqBody` for `ebHash` (§2; `disconnectFrom(peer)` if not); let `el` + be its election. Validate hash = `ebHash`, and against the request (not `LstWanted`): the actual body size + equals the announced `bodySize`, and the body's tx references sum to the announced `closureSize`; on mismatch + `disconnectFrom(peer)` (adversarial). Else, if `LstWanted[el]` still wants `ebHash`: `submitDisk dbWriteBody(body)`, then `BEH-ChunkJobs` — `txCacheOnBody` (§7) hits and Mempool hits (`mempoolQueryPresent`) are copied in (`dbCopyFromTxCache` / `txCacheOnAcquire`), - the rest → jobs — set `LstWanted[el] = AwaitingTxs{ ebHash, jobs }`, - and if no jobs → `complete(el)`. Otherwise the want has moved on (cert switch / tip advance) — drop + the rest → jobs — set `LstWanted[el] = AwaitingTxs` for `ebHash` with those jobs on the fetch side and + `outstandingWrites` = the number of writes just scheduled (the body write, plus the hit-copy write when there were + hits); if there are no jobs → `complete(el)` + (fetch done; the entry stays until those writes land). Otherwise the want has moved on (cert switch / tip advance) — drop the result, no disconnect. Consider fetching. -- **`LevBlockTxs(peer, ebHash, txs)`**: the front of `LstPeerInflight[peer]` must be a `ReqJob _ ebHash jobId` for `ebHash` - — the `jobId` is recovered from that front entry, not the wire (§2; drop if not); let `el` be its election. Validate against the request; on mismatch drop. Else: `scheduleDisk dbWriteTxsIntoClosure`; offer the txs to the TxCache (`txCacheOnAcquire`, §7). - If `LstWanted[el]` still wants `ebHash`, remove `jobId` from its outstanding jobs (only `el` - advances; if now empty → `complete(el)`); otherwise the want has moved on — drop, no disconnect. +- **`LevBlockTxs(peer, ebHash, txs)`**: the front of `LstPeerInflight[peer]` must be a `ReqJob` for `ebHash` + — the `jobId` is recovered from that front entry, not the wire (§2; `disconnectFrom(peer)` if not); let `el` be its election. Validate against the request — the reply's txs must equal the requested job's txs in order; on mismatch `disconnectFrom(peer)` (adversarial). Else: `submitDisk dbWriteTxsIntoClosure(ebHash, txs)`; offer the txs to the TxCache (`txCacheOnAcquire`, §7). + If `LstWanted[el]` still wants `ebHash`, move `jobId` off the fetch side and raise `outstandingWrites` by one + (the closure write just scheduled); if the fetch side is now empty → `complete(el)`. Otherwise the want has + moved on — drop, no disconnect (the write still happens; its `LevDiskDone` is ignored, below). Consider fetching (PeerSharing peers refill toward `peerSharingHighWater`). -- **`LevCertValidated(headerHash, ebHash)`** (the cert for announcement `headerHash`, which announced `ebHash`, has been validated — by ChainSel on a CertRB, or - **[SF]** by `BEH-CertFetch`; emitted only post-validation, so reliable (§6 covers ChainSel's tentative-header timing); `el` = - the announcement's election; **peerless** — the cert is cryptographic — and deduped by election, so it fires at +- **`LevCertValidated(el, headerHash, ebHash, bodySize, closureSize)`** (the certified EB's announcement triple — election `el`, announcement `headerHash`, EB hash `ebHash` — whose cert has been validated — by ChainSel on a CertRB, or + **[SF]** by `BEH-CertFetch`; emitted only post-validation, so reliable (§6 covers ChainSel's tentative-header timing); the triple and the two sizes are supplied by the emitter, so `el` and the sizes are given rather than derived; **peerless** — the cert is cryptographic — and deduped by election, so it fires at most once per election): set `LstCertified[el] = (headerHash, ebHash)` (`BEH-FetchPriority` now ranks `ebHash` top) and ensure `LstWanted[el]` wants `ebHash` — but, exactly as `LevBlockAnnouncement`, only when `ebHash` is neither complete (consult the store via `dbQueryPresent`, as `BEH-Startup` does) nor below the immutable tip, since the cert routinely validates after we already fetched and completed the first-announced EB; if so, add an `AwaitingBody` - entry when absent (sizes from its announcement). Consider fetching. (**[SF]** §6: when `ebHash` *differs* from + entry when absent, using the `bodySize`/`closureSize` the stimulus carries — not a local lookup, since after a + restart the certified EB's announcement may have arrived only in a prior run, leaving `LstFirstAnnouncements[el]` + empty this execution. (ChainSel can recover these sizes either by reading the predecessor's header from disk + or by projecting them from the incoming ledger state's protocol state — which might require adding some fields + to the protocol state, but that is reasonable information to add.) Consider fetching. (**[SF]** §6: when `ebHash` *differs* from the first-seen EB `LstWanted[el]` was tracking, switch `LstWanted[el]` to `ebHash` in place — applying the same completeness check (we may already hold it, e.g. self-issued via `BEH-SelfIssued`): complete ⇒ drop the entry, body present ⇒ `AwaitingTxs`, else `AwaitingBody`; the first-seen's in-flight reqs are left to the @@ -599,14 +676,30 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere `LstPeerFirstAnnouncements[peer]`/`LstPeerOfferings[peer]`/`LstPeerOfferGates[peer]`/`LstPeerNotifyQueue[peer]`/`LstPeerInflight[peer]`. The connection is gone, so no further message from `peer` can arrive. Consider fetching. -- **`LevTimer(timeout, req)`**: `req` is overdue → `disconnectFrom(peer)` for the peer that owns it. - -- **`LevDiskDone(op)`**: mark the bytes stored (now readable); release fan-out deferred on `op`. - -- **`LevImmTipAdvanced(s)`**: `scheduleDisk dbGarbageCollect(s)`/`dbPromote`; range-delete every slot-indexed state variable - below `s` (`BEH-TipAdvance`) — the `Election`-keyed +- **`LevTimer(timeout, peer, req)`**: the timer carries the `peer` it was set for (no search). If `req` is still + in-flight to `peer` it is overdue → `disconnectFrom(peer)`; if `peer` already answered (the entry was popped), + the timer is stale and ignored. + +- **`LevDiskDone(w)`** (`w` is a `DiskWrite` — only writes report completion; GC/promote do not): the bytes are + now stored (readable). If `w` wrote a body, enqueue a body offer (`NotifyBlockOffer`) into `LstPeerNotifyQueue[d]` + for each downstream `d` with `LstPeerOfferGates[d][el] = ebHash`. Then account the write against the closure: if + `LstWanted[el]` is `AwaitingTxs` for `w`'s own `ebHash` (the **retarget guard** — a write for a superseded target + must not decrement the new one; `outstandingWrites` is reached exactly by the writes scheduled for the current + target), decrement `outstandingWrites`. When that empties the entry (`outstandingWrites` zero and the fetch side + already empty), clear `LstWanted[el]` and expose the now-persisted closure: emit `NotifyVotingAndChainSel` + (handing the closure to voting and ChainSel) and enqueue a closure offer (`NotifyBlockTxsOffer`) for those same + `d` — the last write, not every write. No disk query is needed: the in-memory count is exact (the number of `LevDiskDone`s + equals the writes scheduled). + +- **`LevImmTipAdvanced(s)`**: `submitDisk dbPromote` promptly; range-delete every slot-indexed state variable + below `s` (`BEH-ImmTipAdvance`) — the `Election`-keyed `LstFirstAnnouncements`/`LstPeerFirstAnnouncements`/`LstPeerOfferings`/`LstPeerOfferGates`/`LstWanted`/`LstCertified` (**[SF]** §6's `LstAnnouncedCert`). - The TxCache is not pruned here (its own window/age eviction, §7) and `LstPeerInflight` is not GC'd here. Consider fetching. + The disk GC is *not* submitted here — it is delayed (`LevGarbageCollect`, below). The TxCache is not pruned here (its own window/age eviction, §7) and `LstPeerInflight` is not GC'd here. No fetch is triggered: pruning frees no in-flight capacity and adds no offer. + +- **`LevGarbageCollect(s)`**: `submitDisk dbGarbageCollect(s)` — the delayed half of `BEH-ImmTipAdvance`, raised by + the harness once the ChainDB's GC delay since slot `s` became immutable has elapsed. No state change (the model's + slot-indexed state was already pruned by the prompt `LevImmTipAdvanced`); this only tells the disk to drop the + now-safely-collectable volatile data. - **`LevSelfIssued(header, body)`** (peerless; `BEH-SelfIssued`): treat `header` as a first announcement — run `LevBlockAnnouncement`'s central-branch update (record `LstFirstAnnouncements[el]`, make wanted, relay @@ -614,7 +707,7 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere we built the header), exactly as `LevRollForward` skips `LstPeerFirstAnnouncements`. Then run `BEH-ChunkJobs` on `body` directly — no in-flight `Req` to match, we already hold it: the Mempool holds the txs we built the EB from (modulo a churn race), so the closure is acquired via `mempoolQueryPresent`/`txCacheOnAcquire` and - `complete(el)` fires with no fetch. Consider fetching (for any txs the race left un-acquired). + `complete(el)` fires with no fetch; any txs the churn race left un-acquired stay as `AwaitingTxs` jobs, fetched once a peer offers this EB's closure (nothing is fetched here — no peer offers our freshly-issued EB yet). --- @@ -659,8 +752,8 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere the offer→request latency past when it would otherwise be dropped, so the disconnect fires only on a genuine misbehaver. The exact delay — and whether a delay alone suffices vs. refcounting offered content — is unsettled. - Sizes and hashes match the announcement (safety). Every body/closure fetched or served matches both its - announced size and its content hash — a body hashes to its announced `ebHash`, a job's txs match the - requested job — and any mismatch is rejected (adversarial). + announced size and its content hash — a body hashes to its announced `ebHash` and its tx references sum to the + announced `closureSize`, a job's txs match the requested job — and any mismatch disconnects the peer (adversarial). - PeerShare closure cap (safety). `∀ peer : PeerSharing peer, ebHash: peerSharingInFlightBytes(peer, ebHash) ≤ peerSharingClosureByteLimit`. - Per-peer active-EB cap (safety). `∀ peer: activeEbs(peer) ≤ maxActiveEbs[class(peer)]` (per class, never conflated). - In-flight integrity (safety). Across the disconnect/response/timeout races — a response and a @@ -690,6 +783,17 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere ## §5 Anticipated refinements (roadmap) +- **Dedup offers/fetches across elections that share an `EbHash`.** An EB body is a list of tx-references, so its + `EbHash` is content-derived and election-independent: two honest producers electing at different `(slot, pool)` + from the same mempool yield byte-identical bodies and the *same* `EbHash`. The wire offers therefore carry the + *election* — `MsgLeiosBlockOffer(election, ebHash)` / `MsgLeiosBlockTxsOffer(election, ebHash)` — not the `ebHash` + alone. This is a correctness choice, not just tidiness: an `ebHash`-only offer is ambiguous on the receiver — it + cannot tell which `LstWanted[el]` the offer pertains to; "update them all" would oblige the *sender* to dedup or + trip a redundant-message disconnect, and "update one" raises *which one, and does it match what the sender meant?*. + So offers are per-election. The accepted residue: when two elections share an `ebHash` (which is assumed to be rare, for honest issuers), we fetch the + identical body and send a per-election duplicate offer to a peer gated for both. The simplest next refinement would be to dedup body fetches to the same extent we already dedup closure fetches: don't re-request the body if it's already persisted. + It seems unwise to pay the disk-latency to check for the body on _every_ announcement just to dedup the very rare case of the body already being present. + So instead, it seems like this refetch-elimination would require maintaining an in-memory set of which EB bodies are currently persisted---very akin to `LstTxCacheIndex`, although it'll be small enough to contain all un-promoted volatile bodies instead of TxCache's more aggressive eviction rules. - **Staggered requesting** (hold-off before broadening). Soften the "immediately request from every offerer" aggressiveness: while an EB is younger than `staggerDelay` (~1–2 s) measured from its own slot-time (not from when we received offers or issued requests), keep each item @@ -728,6 +832,14 @@ exist, both flagged below: PeerSharing rarest-first, and (§5, not yet) staggere on its own, and can be fetched from a different offerer in parallel: the body analogue of chunking txs into jobs, needing no FEC. (FEC over the segments would be a further elaboration — any sufficient subset reconstructs, so a slow or missing peer costs only its parts. New parameter `bodyJobsSize`.) + - FIXME: we need to be able to _immediately_ confirm that the + chunk we receive from an upstream peer was the right chunk. If + we go this Merkle tree route, then that means the chunk has to + be accompanied by the Merkle inclusion proof, which in turn + requires the upstream peer to have all the chunks. + That means this mechanism does not enable streaming. + It's only benefit is to enable parallel fetching from multiple peers. + For 512 kB, is that going to sufficiently matter? - **Chunk the closure incrementally (incremental offers for streaming closures).** The closure is already split into jobs, but a peer offers it all-or-nothing: `BodyAndClosure` advertises the complete closure, so a peer can only offer once it holds every tx. Independently of whether the body is chunked, a peer could offer the closure incrementally — @@ -803,7 +915,7 @@ conflicting cert claim can be rejected at offer time (§3/§6); `LstAnnouncedCer - **`BEH-CertFetch`**. When any peer has offered a cert and we lack the validated cert, request it from that peer (`MsgLeiosCertRequest(headerHash)`, recording `ReqCert el headerHash`) aggressively (every offerer, no multiplicity cap, `BEH-Timeout` for dead peers). On the response, validate. Invalid → disconnect - only the provider. Valid → emit `LevCertValidated(headerHash, ebHash)` (its full §3 effect — including the + only the provider. Valid → emit `LevCertValidated(el, headerHash, ebHash, bodySize, closureSize)` (its full §3 effect — including the **[SF]** skew extension — then applies). ChainSel, on first processing a CertRB (its header diffused by ChainSync, its body by BlockFetch), is the other emitter of `LevCertValidated` (§1). TODO: while a cert-bearing `LevRollForward`'s header is still preferable to our current selection, @@ -830,8 +942,8 @@ conflicting cert claim can be rejected at offer time (§3/§6); `LstAnnouncedCer (`BEH-CertFetch`) aggressively. `peer` must also stop sending vote notifications for `ebHash`. - **`LevCert(peer, cert)`**: validate `cert` against the `headerHash` of the `MsgLeiosCertRequest(headerHash)` it - answers — the front `ReqCert` of `LstPeerInflight[peer]` (§2; drop if the front isn't a `ReqCert`) — plus the - election committee. Invalid → `disconnectFrom(peer)`. Valid → `scheduleDisk dbWriteCert`, emit `LevCertValidated(headerHash, ebHash)` + answers — the front `ReqCert` of `LstPeerInflight[peer]` (§2; `disconnectFrom(peer)` if the front isn't a `ReqCert`) — plus the + election committee. Invalid → `disconnectFrom(peer)`. Valid → `submitDisk dbWriteCert`, emit `LevCertValidated(el, headerHash, ebHash, bodySize, closureSize)` (`ebHash` = the EB that announcement announced). - **`LevCertRequest(peer, headerHash)`**: if `dbQueryPresent` confirms the store holds the cert for diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs new file mode 100644 index 0000000000..fb44050eab --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -0,0 +1,235 @@ +module Main (main) where + +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (foldl') +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import Test.Tasty +import Test.Tasty.HUnit + +import RefModel + +main :: IO () +main = defaultMain tests + +env :: Env +env = Env 5 2 1000000 65536 30 300 600 (Slot 0) + +el100 :: Election +el100 = Election (Slot 5) (PoolId 1) + +hdr100, hdr101, hdr200 :: RbHeader +hdr100 = RbHeader (HeaderHash 10) el100 (Just (EbAnn (EbHash 100) 200 300)) False True +hdr101 = RbHeader (HeaderHash 11) el100 (Just (EbAnn (EbHash 101) 200 300)) False True +hdr200 = RbHeader (HeaderHash 12) (Election (Slot 6) (PoolId 1)) (Just (EbAnn (EbHash 200) 200 300)) False True + +credit :: Peer -> Stimulus +credit p = LevWiredMsg p MsgLeiosNotificationRequestNext + +dequeue :: Peer -> Stimulus +dequeue = LevNotifyDequeue + +body100 :: Body +body100 = Body (EbHash 100) [TxRef (TxHash 1) 150, TxRef (TxHash 2) 150] 200 + +ann :: Peer -> RbHeader -> Stimulus +ann p h = LevWiredMsg p (MsgLeiosBlockAnnouncement h) + +offer :: Peer -> Election -> EbHash -> Stimulus +offer p el eh = LevWiredMsg p (MsgLeiosBlockOffer el eh) + +txsOffer :: Peer -> Election -> EbHash -> Stimulus +txsOffer p el eh = LevWiredMsg p (MsgLeiosBlockTxsOffer el eh) + +runWith :: Ifaces Identity -> [Stimulus] -> (St, [Effect]) +runWith ifs = foldl' go (emptySt, []) + where go (st, fx) s = let (st', fx') = runIdentity (step ifs env (Time 0) s st) in (st', fx ++ fx') + +run :: [Stimulus] -> (St, [Effect]) +run = runWith nullIfaces + +foldEnv :: Env -> [Stimulus] -> (St, [Effect]) +foldEnv e = foldl' go (emptySt, []) + where go (st, fx) s = let (st', fx') = runIdentity (step nullIfaces e (Time 0) s st) in (st', fx ++ fx') + +servingIfaces :: Ifaces Identity +servingIfaces = nullIfaces + { ifDb = (ifDb nullIfaces) + { dbQueryPresent = pure + , dbReadClosureTxs = \_ hs -> pure [ Tx h 1 | h <- hs ] } } + + +isReq :: Effect -> Bool +isReq (Send _ (MsgLeiosBlockRequest _)) = True +isReq (Send _ (MsgLeiosBlockTxsRequest _ _)) = True +isReq _ = False + +isDisconnect :: Effect -> Bool +isDisconnect (Disconnect _ _) = True +isDisconnect _ = False + +tests :: TestTree +tests = testGroup "Leios RefModel — Spec.md main spec" + [ testCase "BEH-PeerChurn: LevPeerAdd registers an Active peer, no effects" $ do + let (st, fx) = run [LevPeerAdd (Peer 1) StakeSampled] + fx @?= [] + fmap peerPhase (Map.lookup (Peer 1) (stPeerPresent st)) @?= Just Active + + , testCase "BEH-Wanting: an announcement gates the want (AwaitingBody), no fetch yet" $ do + let (st, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100] + Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + assertBool "no request before an offer" (not (any isReq fx)) + + , testCase "BEH-Offers + BEH-BodyFetch: an offer for the first-announced EB issues ReqBody" $ do + let (_, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100)] + assertBool "sends MsgLeiosBlockRequest" (Send (Peer 1) (MsgLeiosBlockRequest (EbHash 100)) `elem` fx) + + , testCase "BEH-ChunkJobs + BEH-ClosureFetch: body then closure-offer requests the chunked job's txs" $ do + let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) ] + [ txs | Send _ (MsgLeiosBlockTxsRequest _ txs) <- fx ] @?= [NE.fromList [TxHash 1, TxHash 2]] + assertBool "want advanced to AwaitingTxs" + (case Map.lookup el100 (stWanted st) of Just AwaitingTxs{} -> True; _ -> False) + + , testCase "Job: jobBytes is the real summed tx size" $ do + let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] + jobBytes st el100 (EbHash 100) (JobId 0) @?= 300 + + , testCase "BEH-NotifyServe: a dequeue ships the buffered announcement and opens the gate" $ do + let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled + , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2) ] + assertBool "relays the announcement to Peer 2" (Send (Peer 2) (MsgLeiosBlockAnnouncement hdr100) `elem` fx) + (Map.lookup (Peer 2) (stPeerOfferGates st) >>= Map.lookup el100) @?= Just (EbHash 100) + + , testCase "BEH-NotifyServe: an enqueue that grows the queue emits NotifyEnqueue" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled + , credit (Peer 2), ann (Peer 1) hdr100 ] + length [ () | NotifyEnqueue (Peer 2) <- fx ] @?= 1 + + , testCase "BEH-NotifyServe back-pressure: with no credit nothing is buffered and no NotifyEnqueue fires" $ do + let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled, ann (Peer 1) hdr100 ] + q = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + assertBool "queue empty without a credit" (Set.null q) + assertBool "no NotifyEnqueue for Peer 2" (null [ () | NotifyEnqueue (Peer 2) <- fx ]) + + , testCase "BEH-NotifyServe back-pressure: a full queue evicts the notifyPriority-min, and only the enqueue with an unoccupied credit emits NotifyEnqueue" $ do + let setup ps = run ([ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled, credit (Peer 2) ] ++ ps) + qOf (st, _) = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + enqOf (_, fx) = length [ () | NotifyEnqueue (Peer 2) <- fx ] + stalerFirst = setup [ ann (Peer 1) hdr100, ann (Peer 1) hdr200 ] + fresherFirst = setup [ ann (Peer 1) hdr200, ann (Peer 1) hdr100 ] + qOf stalerFirst @?= Set.singleton (NotifyAnnouncement hdr200) + qOf fresherFirst @?= Set.singleton (NotifyAnnouncement hdr200) + enqOf stalerFirst @?= 1 + enqOf fresherFirst @?= 1 + + , testCase "BEH-NotifyServe back-pressure: credits up to notifyMaxCapacity raise capacity, no disconnect" $ do + let envCap2 = env { envNotifyMaxCapacity = 2 } + (st, fx) = foldEnv envCap2 (LevPeerAdd (Peer 2) PeerSharingSampled : replicate 2 (credit (Peer 2))) + (snd <$> Map.lookup (Peer 2) (stPeerNotifyQueue st)) @?= Just 2 + assertBool "no disconnect within the bound" (not (any isDisconnect fx)) + + , testCase "BEH-NotifyServe back-pressure: over-crediting past notifyMaxCapacity disconnects" $ do + let envCap2 = env { envNotifyMaxCapacity = 2 } + (st, fx) = foldEnv envCap2 (LevPeerAdd (Peer 2) PeerSharingSampled : replicate 3 (credit (Peer 2))) + assertBool "disconnects on the excess credit" (Disconnect (Peer 2) ExcessNotifyCredits `elem` fx) + (snd <$> Map.lookup (Peer 2) (stPeerNotifyQueue st)) @?= Just 2 + + , testCase "BEH-NotifyServe: an inbound notification far below the immutable tip disconnects (stale)" $ do + let envStale = env { envImmutableTip = Slot 700 } -- hdr100 is slot 5, i.e. 695 > notifyStaleHorizon (600) + (_, fx) = foldEnv envStale [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 ] + assertBool "disconnects on the stale notification" (Disconnect (Peer 1) StaleNotification `elem` fx) + + , testCase "BEH-NotifyServe: an inbound notification within the staleness horizon is not a disconnect" $ do + let envNear = env { envImmutableTip = Slot 100 } -- hdr100 is slot 5, only 95 < notifyStaleHorizon (600) + (_, fx) = foldEnv envNear [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 ] + assertBool "no stale disconnect within the horizon" (not (any isDisconnect fx)) + + , testCase "BEH-NotifyServe: a dequeue discards a notification older than the immutable tip" $ do + let envT = env { envImmutableTip = Slot 6 } + (st0, _) = foldEnv envT [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled + , credit (Peer 2), ann (Peer 1) hdr100 ] + (st1, fx) = runIdentity (step nullIfaces envT (Time 0) (dequeue (Peer 2)) st0) + assertBool "stale notification not sent" (null [ () | Send (Peer 2) _ <- fx ]) + assertBool "stale notification discarded" (maybe True (Set.null . fst) (Map.lookup (Peer 2) (stPeerNotifyQueue st1))) + + , testCase "BEH-ImmTipAdvance: promote is prompt, GC is deferred" $ do + let envT = env { envImmutableTip = Slot 7 } + (_, fx) = runIdentity (step nullIfaces envT (Time 0) LevImmTipAdvanced emptySt) + assertBool "promotes slot 7" (SubmitDisk (Promote (Slot 7)) `elem` fx) + assertBool "no GC at advance" (null [ () | SubmitDisk (GarbageCollect _) <- fx ]) + + , testCase "BEH-ImmTipAdvance: a deferred LevGarbageCollect submits the disk GC" $ do + let (_, fx) = runIdentity (step nullIfaces env (Time 0) (LevGarbageCollect (Slot 7)) emptySt) + fx @?= [SubmitDisk (GarbageCollect (Slot 7))] + + , testCase "BEH-Wanting: a genuine equivocation is accepted; first EB stays wanted, equivocating never" $ do + let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) ] + assertBool "no disconnect" (not (any isDisconnect fx)) + Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + + , testCase "BEH-Offers: an offer for an equivocating (non-first) EB disconnects" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) + , offer (Peer 1) el100 (EbHash 101) ] + assertBool "disconnects (unannounced offer)" (Disconnect (Peer 1) UnannouncedOffer `elem` fx) + + , testCase "BEH-Responses: a body whose closure size mismatches the announcement disconnects" $ do + let badBody = Body (EbHash 100) [TxRef (TxHash 1) 1] 200 + (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) badBody) ] + assertBool "disconnects with BodyMismatch" (Disconnect (Peer 1) BodyMismatch `elem` fx) + + , testCase "BEH-Responses: an unsolicited body (no matching in-flight request) disconnects" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] + assertBool "disconnects with UnsolicitedResponse" (Disconnect (Peer 1) UnsolicitedResponse `elem` fx) + + , testCase "BEH-Responses: a tx-closure reply in the wrong order disconnects" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlockTxs (EbHash 100) [Tx (TxHash 2) 150, Tx (TxHash 1) 150]) ] + assertBool "disconnects with TxsMismatch" (Disconnect (Peer 1) TxsMismatch `elem` fx) + + , testCase "BEH-FetchServe: a tx request is served with the requested txs in order" $ do + let (_, fx) = runWith servingIfaces + [ LevPeerAdd (Peer 2) PeerSharingSampled + , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [TxHash 1, TxHash 2])) ] + [ ts | Send _ (MsgLeiosBlockTxs _ ts) <- fx ] @?= [[Tx (TxHash 1) 1, Tx (TxHash 2) 1]] + + , testCase "BEH-Completion: finishing a body write enqueues a body offer to gated peers" $ do + let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled + , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) + , LevDiskDone (WriteBody el100 body100) ] + q = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + assertBool "body offer enqueued" (Set.member (NotifyBlockOffer el100 (EbHash 100)) q) + + , testCase "BEH-Completion: voting + ChainSel are notified only when the last write lands (persist-gated)" $ do + let txs = [Tx (TxHash 1) 150, Tx (TxHash 2) 150] + setup = [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlockTxs (EbHash 100) txs) ] + exposed fx = NotifyVotingAndChainSel el100 (EbHash 100) `elem` fx + (_, fx1) = run (setup ++ [ LevDiskDone (WriteBody el100 body100) ]) + (st2, fx2) = run (setup ++ [ LevDiskDone (WriteBody el100 body100) + , LevDiskDone (WriteClosure el100 (EbHash 100) txs) ]) + assertBool "fetch-complete + first write expose nothing" (not (exposed fx1)) + assertBool "last write notifies voting and ChainSel" (exposed fx2) + assertBool "and the want is cleared" (not (Map.member el100 (stWanted st2))) + + , testCase "BEH-Wanting: a validated cert (no prior want) creates an AwaitingBody with the carried sizes" $ do + let (st, _) = run [ LevCertValidated (AnnouncementTriple el100 (HeaderHash 10) (EbHash 100)) 200 300 ] + Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + + , testCase "§4 safety properties hold on the closure-fetch scenario" $ do + let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) ] + assertBool "want announcement-gated" (prop_wantAnnouncementGated st) + assertBool "per-peer active-EB cap" (prop_perPeerActiveEbCap env st) + assertBool "offers announced/certified" (prop_offersAnnouncedOrCertified st) + assertBool "in-flight offered" (prop_inflightOffered st) + ] From f1d6672249f106b7a6e10f17df86174078265942 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sat, 27 Jun 2026 14:56:45 -0400 Subject: [PATCH 03/16] WIP introduce EbHashMap --- .../Test/Leios/RefModel/EbHashMap.hs | 188 ++++++++++++++++++ .../Test/Leios/RefModel/RefModel.hs | 24 +-- .../Test/Leios/RefModel/test/RefModelTest.hs | 102 +++++++++- 3 files changed, 298 insertions(+), 16 deletions(-) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs new file mode 100644 index 0000000000..9f78cc8e52 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} + +-- | A type for managing maps over 'EbHash' but entries can't exist +-- without a 'Election' that justifies them +-- +-- Note that there's at most two 'EbHash'es per 'Election'. That'll be +-- the first-announced and then the certified EB if it's different +-- (which should be impossible/rare due to L_hdr). +module EbHashMap ( + -- * Identifiers + Slot (..) + , PoolId (..) + , Election (..) + , electionSlot + , EbHash (..) + -- * Reference-counted bidirectional election/EB map + , Refs (..) + , InactiveRef (..) + , RefCount (..) + , EbHashMap (..) + , activeRef + -- * Construction + , empty + , upsert + , supersede + -- * Query + , lookupEb + , lookupElection + , refCount + -- * Update + , updateEb + -- * Deletion / GC + , deleteElection + , pruneElections + -- * Invariant (for tests) + , invariant + ) where + +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Word (Word16, Word64) + +newtype Slot = Slot Word64 deriving (Eq, Ord, Show) +newtype PoolId = PoolId Word64 deriving (Eq, Ord, Show) +newtype EbHash = EbHash Word64 deriving (Eq, Ord, Show) + +data Election = Election Slot PoolId -- election = (slot, pool) + deriving (Eq, Ord, Show) + +electionSlot :: Election -> Slot +electionSlot (Election s _) = s + +-- | An election's references: the inactive (superseded) reference, the active +-- reference, and a per-election payload. +-- +-- INVARIANT: the active reference is never equal to the inactive one. +data Refs b = Refs !InactiveRef !EbHash !b + deriving (Eq, Functor, Show) + +data InactiveRef = + NoInactiveRefYet + | -- | 'supersede' was called before 'insert' + NoInactiveRef + | InactiveRef !EbHash + deriving (Eq, Show) + +activeRef :: Refs b -> EbHash +activeRef (Refs _ act _) = act + +-- | An EB's reference count (the number of elections naming it, active or +-- inactive) and a per-EB payload. +-- +-- INVARIANT: the count is positive (i.e. strictly > 0); an entry exists iff +-- some election names it. +data RefCount a = RefCount !Word16 !a + deriving (Eq, Functor, Show) + +instance Semigroup a => Semigroup (RefCount a) + where + RefCount n x <> RefCount m y = RefCount (n + m) (x <> y) + +refCount :: RefCount a -> Word16 +refCount (RefCount n _) = n + +----- + +-- | A bidirectional, reference-counted map between elections and the EBs they +-- name: @a@ is the per-EB payload, @b@ the per-election payload. +-- +-- INVARIANT: the EB map's keys are exactly the EBs named (active or inactive) by +-- some election, and each EB's count equals the number of elections naming it. +data EbHashMap a b = + EbHashMap + !(Map EbHash (RefCount a)) + !(Map Election (Refs b)) + deriving (Eq, Show) + +empty :: EbHashMap a b +empty = EbHashMap Map.empty Map.empty + +incRef :: Semigroup a => EbHash -> a -> Map EbHash (RefCount a) -> Map EbHash (RefCount a) +incRef eh a = Map.insertWith collide eh (RefCount 1 a) + where + collide new old = old <> new + +decRef :: EbHash -> Map EbHash (RefCount a) -> Map EbHash (RefCount a) +decRef = Map.update step + where + step (RefCount n x) + | n <= 1 = Nothing + | otherwise = Just (RefCount (n - 1) x) + +-- | This @b@ value is only the default; update it with 'supersede' +upsert :: Semigroup a => EbHash -> Election -> a -> b -> EbHashMap a b -> EbHashMap a b +upsert eh el a' b (EbHashMap ebs els) = + case Map.lookup el els of + Nothing -> + EbHashMap (incRef eh a' ebs) (setEl (Refs NoInactiveRefYet eh b)) + Just (Refs _ act _) + | act == eh -> EbHashMap (Map.adjust (fmap (<> a')) eh ebs) els + | otherwise -> error "EbHashMap.insert: inserted the wrong EbHash" + where + setEl r = Map.insert el r els + +-- | 'Nothing' if the lookup missed or the update returned 'Nothing' +updateEb :: EbHash -> (a -> Maybe a) -> EbHashMap a b -> Maybe (EbHashMap a b) +updateEb eh f (EbHashMap ebs els) = + (\x -> EbHashMap x els) <$> + Map.alterF + (\case + Nothing -> Nothing + Just (RefCount n x) -> do + !y <- f x + Just (Just (RefCount n y)) + ) + eh + ebs + +-- | This @a@ value is only the default; update it with 'upsert' or 'updateEb' +supersede :: Semigroup a => Election -> EbHash -> a -> b -> EbHashMap a b -> EbHashMap a b +supersede el eh a b (EbHashMap ebs els) = + case Map.lookup el els of + Nothing -> + EbHashMap (incRef eh a ebs) (Map.insert el (Refs NoInactiveRef eh b) els) + Just (Refs NoInactiveRefYet act _) + | act == eh -> EbHashMap (Map.adjust (fmap (<> a)) eh ebs) (Map.insert el (Refs NoInactiveRef act b) els) + | otherwise -> EbHashMap (incRef eh a ebs) (Map.insert el (Refs (InactiveRef act) eh b) els) + Just (Refs NoInactiveRef _ _) -> error "EbHashMap.supersede: election already superseded" + Just (Refs InactiveRef{} _ _) -> error "EbHashMap.supersede: election already superseded" + +lookupEb :: EbHash -> EbHashMap a b -> Maybe (RefCount a) +lookupEb eh (EbHashMap ebs _) = Map.lookup eh ebs + +lookupElection :: Election -> EbHashMap a b -> Maybe (Refs b) +lookupElection el (EbHashMap _ els) = Map.lookup el els + +deleteElection :: Election -> EbHashMap a b -> EbHashMap a b +deleteElection el m@(EbHashMap ebs els) = + case Map.lookup el els of + Nothing -> m + Just (Refs inact act _) -> EbHashMap (dropRefs ebs inact act) (Map.delete el els) + +pruneElections :: (Election -> Bool) -> EbHashMap a b -> EbHashMap a b +pruneElections p (EbHashMap ebs els) = + EbHashMap (foldl' step ebs (Map.elems dropped)) kept + where + (dropped, kept) = Map.partitionWithKey (\el _ -> p el) els + step acc (Refs inact act _) = dropRefs acc inact act + +dropRefs :: Map EbHash (RefCount a) -> InactiveRef -> EbHash -> Map EbHash (RefCount a) +dropRefs ebs inact act = + case inact of InactiveRef old -> decRef old (decRef act ebs); _ -> decRef act ebs + +invariant :: EbHashMap a b -> Bool +invariant (EbHashMap ebs els) = + all neverEqual (Map.elems els) + && Map.keys tally == Map.keys ebs + && and (Map.intersectionWith (\n (RefCount m _) -> n == m) tally ebs) + && all (\(RefCount n _) -> 0 < n) (Map.elems ebs) + where + neverEqual (Refs inact act _) = case inact of InactiveRef eh -> eh /= act; _ -> True + tally = foldl' count Map.empty (Map.elems els) + count m (Refs inact act _) = + let m1 = Map.insertWith (+) act (1 :: Word16) m + in case inact of InactiveRef old -> Map.insertWith (+) old 1 m1; _ -> m1 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index a955ddc33a..01fdd7282a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -1,5 +1,8 @@ -module RefModel where +module RefModel (module RefModel) where +import EbHashMap (EbHash (..), Election (..), electionSlot, PoolId (..), Slot (..)) +import EbHashMap (EbHashMap) +import qualified EbHashMap as EM import Data.Foldable (foldl', toList) import Data.List (maximumBy, minimumBy, sortOn) import Data.List.NonEmpty (NonEmpty) @@ -20,21 +23,12 @@ import Data.These (These (..)) import Data.Word (Word16, Word64) newtype ByteCount = ByteCount Word64 deriving (Eq, Num, Ord, Show) -newtype Slot = Slot Word64 deriving (Eq, Ord, Show) -newtype PoolId = PoolId Word64 deriving (Eq, Ord, Show) newtype Peer = Peer Word64 deriving (Eq, Ord, Show) -newtype EbHash = EbHash Word64 deriving (Eq, Ord, Show) newtype HeaderHash = HeaderHash Word64 deriving (Eq, Ord, Show) newtype TxHash = TxHash Word64 deriving (Eq, Ord, Show) newtype JobId = JobId Word64 deriving (Eq, Ord, Show) newtype Time = Time Word64 deriving (Eq, Ord, Show) -data Election = Election Slot PoolId -- election = (slot, pool) - deriving (Eq, Ord, Show) - -electionSlot :: Election -> Slot -electionSlot (Election s _) = s - data Class = StakeSampled | PeerSharingSampled -- BEH-PeerClass deriving (Eq, Ord, Show) @@ -166,7 +160,7 @@ data St = St { stFirstAnnouncements :: Map Election AnnState -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: Map Peer (Map Election AnnSeen) -- §2 LstPeerFirstAnnouncements , stPeerOfferings :: Map Peer (Map Election (These CertSide OfferSide)) -- §2 LstPeerOfferings - , stPeerOfferGates :: Map Peer (Map Election EbHash) -- §2 LstPeerOfferGates + , stPeerOfferGates :: Map Peer (EbHashMap () ()) -- §2 LstPeerOfferGates , stPeerNotifyQueue :: Map Peer (Set Notification, Int) -- §2 LstPeerNotifyQueue , stWanted :: Map Election WantState -- §2 LstWanted , stCertified :: Map Election (HeaderHash, EbHash) -- §2 LstCertified @@ -669,8 +663,8 @@ sendNotification peer n st = case n of openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates openGate peer el eh st = - st { stPeerOfferGates = Map.insert peer (Map.insert el eh perPeer) (stPeerOfferGates st) } - where perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferGates st)) + st { stPeerOfferGates = Map.insert peer (EM.upsert eh el () () perPeer) (stPeerOfferGates st) } + where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock hBlock ifs env now peer eh body st = case frontReq st peer of @@ -867,7 +861,7 @@ enqueueOffer :: Notification -> Election -> EbHash -> St -> (St, [Effect]) -- B enqueueOffer notif el eh st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer notif s in (s', fx ++ fx')) (st, []) gated where - gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), Map.lookup el gates == Just eh ] + gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), (EM.activeRef <$> EM.lookupElection el gates) == Just eh ] enqueueBodyOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion enqueueBodyOffers el eh = enqueueOffer (NotifyBlockOffer el eh) el eh @@ -882,7 +876,7 @@ pruneBelow s st = st , stCertified = pruneElectionMap s (stCertified st) , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) , stPeerOfferings = Map.map (pruneElectionMap s) (stPeerOfferings st) - , stPeerOfferGates = Map.map (pruneElectionMap s) (stPeerOfferGates st) + , stPeerOfferGates = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferGates st) } pruneElectionMap :: Slot -> Map Election a -> Map Election a diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index fb44050eab..e6166712f9 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -4,11 +4,15 @@ import Data.Functor.Identity (Identity, runIdentity) import Data.List (foldl') import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid (Sum (..)) import qualified Data.Set as Set import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import EbHashMap import RefModel main :: IO () @@ -102,7 +106,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2) ] assertBool "relays the announcement to Peer 2" (Send (Peer 2) (MsgLeiosBlockAnnouncement hdr100) `elem` fx) - (Map.lookup (Peer 2) (stPeerOfferGates st) >>= Map.lookup el100) @?= Just (EbHash 100) + (activeRef <$> (Map.lookup (Peer 2) (stPeerOfferGates st) >>= lookupElection el100)) @?= Just (EbHash 100) , testCase "BEH-NotifyServe: an enqueue that grows the queue emits NotifyEnqueue" $ do let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled @@ -232,4 +236,100 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "per-peer active-EB cap" (prop_perPeerActiveEbCap env st) assertBool "offers announced/certified" (prop_offersAnnouncedOrCertified st) assertBool "in-flight offered" (prop_inflightOffered st) + + , testProperty "EbHashMap: invariant + op postconditions hold across random op sequences" + (withMaxSuccess 2000 prop_ebHashMap) + + , testCase "EbHashMap: per-EB payload combines via <> across references" $ do + let el1 = Election (Slot 1) (PoolId 0) + el2 = Election (Slot 2) (PoolId 0) + el3 = Election (Slot 3) (PoolId 0) + el4 = Election (Slot 4) (PoolId 0) + ehA = EbHash 10 + ehB = EbHash 11 + ehC = EbHash 12 + ehD = EbHash 13 + m0 = empty :: EbHashMap [Int] () + m1 = upsert ehA el1 [1] () m0 + m2 = upsert ehA el2 [2] () m1 -- second election names ehA: incRef combines + m3 = upsert ehA el1 [3] () m2 -- re-upsert same active: adjust combines + m4 = supersede el1 ehB [9] () m3 -- el1 switches to ehB; ehA untouched, now el1's inactive + m5 = fromMaybe m4 (updateEb ehA (Just . (<> [4])) m4) + mC = supersede el3 ehC [6] () (upsert ehC el3 [5] () m5) -- supersede with active==eh combines + m = supersede el4 ehD [7] () mC -- supersede before any upsert + lookupEb ehA m @?= Just (RefCount 2 [1, 2, 3, 4]) + lookupEb ehB m @?= Just (RefCount 1 [9]) + lookupEb ehC m @?= Just (RefCount 1 [5, 6]) + lookupEb ehD m @?= Just (RefCount 1 [7]) + assertBool "invariant holds" (invariant m) ] + +-- EbHashMap property test -------------------------------------------------- + +-- | A random operation over a small key space (so collisions, supersessions, +-- and shared EbHashes across elections are common). +data Op + = OpInsert Election EbHash Int Int + | OpSupersede Election EbHash Int Int + | OpDelete Election + | OpPrune Slot + deriving Show + +genElection :: Gen Election +genElection = Election <$> (Slot . fromIntegral <$> chooseInt (0, 5)) + <*> (PoolId . fromIntegral <$> chooseInt (0, 2)) + +genEbHash :: Gen EbHash +genEbHash = EbHash . fromIntegral <$> chooseInt (0, 4) + +instance Arbitrary Op where + arbitrary = oneof + [ OpInsert <$> genElection <*> genEbHash <*> arbitrary <*> arbitrary + , OpSupersede <$> genElection <*> genEbHash <*> arbitrary <*> arbitrary + , OpDelete <$> genElection + , OpPrune . Slot . fromIntegral <$> chooseInt (0, 6) + ] + +activeOf :: Election -> EbHashMap a b -> Maybe EbHash +activeOf el m = activeRef <$> lookupElection el m + +-- | The ops error on misuse; only apply each when its precondition holds. +insertValid :: Election -> EbHash -> EbHashMap a b -> Bool +insertValid el eh m = maybe True (== eh) (activeOf el m) + +supersedeValid :: Election -> EbHash -> EbHashMap a b -> Bool +supersedeValid el _ m = case lookupElection el m of + Nothing -> True -- cert before announcement + Just (Refs NoInactiveRefYet _ _) -> True -- first cert for this election + Just (Refs NoInactiveRef _ _) -> False -- already superseded + Just (Refs (InactiveRef _) _ _) -> False -- already superseded + +apply :: Op -> EbHashMap (Sum Int) (Sum Int) -> EbHashMap (Sum Int) (Sum Int) +apply op m = case op of + OpInsert el eh a b -> if insertValid el eh m then upsert eh el (Sum a) (Sum b) m else m + OpSupersede el eh a b -> if supersedeValid el eh m then supersede el eh (Sum a) (Sum b) m else m + OpDelete el -> deleteElection el m + OpPrune s -> pruneElections (\e -> electionSlot e < s) m + +electionsOf :: EbHashMap a b -> [Election] +electionsOf (EbHashMap _ els) = Map.keys els + +postcond :: Op -> EbHashMap (Sum Int) (Sum Int) -> EbHashMap (Sum Int) (Sum Int) -> Bool +postcond op pre post = case op of + OpInsert el eh _ _ -> case lookupElection el pre of -- a fresh announce sets the active + Nothing -> activeOf el post == Just eh + _ -> True + OpSupersede el eh _ _ -> not (supersedeValid el eh pre) || activeOf el post == Just eh + OpDelete el -> isNothing (lookupElection el post) + OpPrune s -> all (\e -> not (electionSlot e < s)) (electionsOf post) + +prop_ebHashMap :: [Op] -> Property +prop_ebHashMap = go empty + where + go _ [] = property True + go m (op : ops) = + let m' = apply op m + in counterexample + (show op <> "\n before: " <> show m <> "\n after: " <> show m') + (invariant m' && postcond op m m') + .&&. go m' ops From c72412139de6b5514b0237ead4f7464106cd3d95 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sat, 27 Jun 2026 18:46:26 -0400 Subject: [PATCH 04/16] WIP big change: dedup _hard_ on EBs, so Msg*Offer doesn't need to carry elections --- .../Test/Leios/RefModel/EbHashMap.hs | 87 ++-- .../Test/Leios/RefModel/RefModel.hs | 414 ++++++++++-------- .../Test/Leios/RefModel/test/RefModelTest.hs | 60 +-- 3 files changed, 320 insertions(+), 241 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs index 9f78cc8e52..2e6101377f 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs @@ -3,7 +3,8 @@ {-# LANGUAGE LambdaCase #-} -- | A type for managing maps over 'EbHash' but entries can't exist --- without a 'Election' that justifies them +-- without an 'Election' that justifies them. For example, a node only +-- ever wants some EB because some election(s) require that EB. -- -- Note that there's at most two 'EbHash'es per 'Election'. That'll be -- the first-announced and then the certified EB if it's different @@ -18,7 +19,7 @@ module EbHashMap ( -- * Reference-counted bidirectional election/EB map , Refs (..) , InactiveRef (..) - , RefCount (..) + , RefCounts (..) , EbHashMap (..) , activeRef -- * Construction @@ -70,20 +71,17 @@ data InactiveRef = activeRef :: Refs b -> EbHash activeRef (Refs _ act _) = act --- | An EB's reference count (the number of elections naming it, active or --- inactive) and a per-EB payload. +-- | An EB's active and inactive reference counts (how many elections name it as +-- their active EB, and how many as their inactive/superseded EB) and a per-EB +-- payload. -- --- INVARIANT: the count is positive (i.e. strictly > 0); an entry exists iff --- some election names it. -data RefCount a = RefCount !Word16 !a +-- INVARIANT: the total count is positive (i.e. active + inactive > 0); an entry +-- exists iff some election names it. +data RefCounts a = RefCounts !Word16 !Word16 !a deriving (Eq, Functor, Show) -instance Semigroup a => Semigroup (RefCount a) - where - RefCount n x <> RefCount m y = RefCount (n + m) (x <> y) - -refCount :: RefCount a -> Word16 -refCount (RefCount n _) = n +refCount :: RefCounts a -> Word16 +refCount (RefCounts a i _) = a + i ----- @@ -94,31 +92,51 @@ refCount (RefCount n _) = n -- some election, and each EB's count equals the number of elections naming it. data EbHashMap a b = EbHashMap - !(Map EbHash (RefCount a)) + !(Map EbHash (RefCounts a)) !(Map Election (Refs b)) deriving (Eq, Show) empty :: EbHashMap a b empty = EbHashMap Map.empty Map.empty -incRef :: Semigroup a => EbHash -> a -> Map EbHash (RefCount a) -> Map EbHash (RefCount a) -incRef eh a = Map.insertWith collide eh (RefCount 1 a) +incRefActive :: Semigroup a => EbHash -> a -> Map EbHash (RefCounts a) -> Map EbHash (RefCounts a) +incRefActive eh a = Map.alter step eh + where + step Nothing = Just (RefCounts 1 0 a) + step (Just (RefCounts n i x)) = Just (RefCounts (n + 1) i (x <> a)) + +-- | For one election: convert its reference to @old@ from active to inactive, and +-- add an active reference to @new@ (payload @a@). (@old@'s total is unchanged; @new@ +-- gains one.) We never deactivate a reference without activating a different one. +deactivateRef :: Semigroup a => EbHash -> EbHash -> a -> Map EbHash (RefCounts a) -> Map EbHash (RefCounts a) +deactivateRef old new a = incRefActive new a . Map.adjust step old + where + step (RefCounts ac i x) + | ac == 0 = error "EbHashMap.deactivateRef: no active reference" + | otherwise = RefCounts (ac - 1) (i + 1) x + +decRefActive :: EbHash -> Map EbHash (RefCounts a) -> Map EbHash (RefCounts a) +decRefActive = Map.update step where - collide new old = old <> new + step (RefCounts a i x) + | a == 0 = error "EbHashMap.decRefActive: no active reference" + | a + i <= 1 = Nothing + | otherwise = Just (RefCounts (a - 1) i x) -decRef :: EbHash -> Map EbHash (RefCount a) -> Map EbHash (RefCount a) -decRef = Map.update step +decRefInactive :: EbHash -> Map EbHash (RefCounts a) -> Map EbHash (RefCounts a) +decRefInactive = Map.update step where - step (RefCount n x) - | n <= 1 = Nothing - | otherwise = Just (RefCount (n - 1) x) + step (RefCounts a i x) + | i == 0 = error "EbHashMap.decRefInactive: no inactive reference" + | a + i <= 1 = Nothing + | otherwise = Just (RefCounts a (i - 1) x) -- | This @b@ value is only the default; update it with 'supersede' upsert :: Semigroup a => EbHash -> Election -> a -> b -> EbHashMap a b -> EbHashMap a b upsert eh el a' b (EbHashMap ebs els) = case Map.lookup el els of Nothing -> - EbHashMap (incRef eh a' ebs) (setEl (Refs NoInactiveRefYet eh b)) + EbHashMap (incRefActive eh a' ebs) (setEl (Refs NoInactiveRefYet eh b)) Just (Refs _ act _) | act == eh -> EbHashMap (Map.adjust (fmap (<> a')) eh ebs) els | otherwise -> error "EbHashMap.insert: inserted the wrong EbHash" @@ -132,9 +150,9 @@ updateEb eh f (EbHashMap ebs els) = Map.alterF (\case Nothing -> Nothing - Just (RefCount n x) -> do + Just (RefCounts n i x) -> do !y <- f x - Just (Just (RefCount n y)) + Just (Just (RefCounts n i y)) ) eh ebs @@ -144,14 +162,14 @@ supersede :: Semigroup a => Election -> EbHash -> a -> b -> EbHashMap a b -> EbH supersede el eh a b (EbHashMap ebs els) = case Map.lookup el els of Nothing -> - EbHashMap (incRef eh a ebs) (Map.insert el (Refs NoInactiveRef eh b) els) + EbHashMap (incRefActive eh a ebs) (Map.insert el (Refs NoInactiveRef eh b) els) Just (Refs NoInactiveRefYet act _) | act == eh -> EbHashMap (Map.adjust (fmap (<> a)) eh ebs) (Map.insert el (Refs NoInactiveRef act b) els) - | otherwise -> EbHashMap (incRef eh a ebs) (Map.insert el (Refs (InactiveRef act) eh b) els) + | otherwise -> EbHashMap (deactivateRef act eh a ebs) (Map.insert el (Refs (InactiveRef act) eh b) els) Just (Refs NoInactiveRef _ _) -> error "EbHashMap.supersede: election already superseded" Just (Refs InactiveRef{} _ _) -> error "EbHashMap.supersede: election already superseded" -lookupEb :: EbHash -> EbHashMap a b -> Maybe (RefCount a) +lookupEb :: EbHash -> EbHashMap a b -> Maybe (RefCounts a) lookupEb eh (EbHashMap ebs _) = Map.lookup eh ebs lookupElection :: Election -> EbHashMap a b -> Maybe (Refs b) @@ -170,19 +188,20 @@ pruneElections p (EbHashMap ebs els) = (dropped, kept) = Map.partitionWithKey (\el _ -> p el) els step acc (Refs inact act _) = dropRefs acc inact act -dropRefs :: Map EbHash (RefCount a) -> InactiveRef -> EbHash -> Map EbHash (RefCount a) +dropRefs :: Map EbHash (RefCounts a) -> InactiveRef -> EbHash -> Map EbHash (RefCounts a) dropRefs ebs inact act = - case inact of InactiveRef old -> decRef old (decRef act ebs); _ -> decRef act ebs + case inact of InactiveRef old -> decRefInactive old (decRefActive act ebs); _ -> decRefActive act ebs invariant :: EbHashMap a b -> Bool invariant (EbHashMap ebs els) = all neverEqual (Map.elems els) && Map.keys tally == Map.keys ebs - && and (Map.intersectionWith (\n (RefCount m _) -> n == m) tally ebs) - && all (\(RefCount n _) -> 0 < n) (Map.elems ebs) + && and (Map.intersectionWith (\(a, i) (RefCounts a' i' _) -> a == a' && i == i') tally ebs) + && all (\(RefCounts a i _) -> 0 < a + i) (Map.elems ebs) where neverEqual (Refs inact act _) = case inact of InactiveRef eh -> eh /= act; _ -> True tally = foldl' count Map.empty (Map.elems els) count m (Refs inact act _) = - let m1 = Map.insertWith (+) act (1 :: Word16) m - in case inact of InactiveRef old -> Map.insertWith (+) old 1 m1; _ -> m1 + let m1 = Map.insertWith addPair act ((1, 0) :: (Word16, Word16)) m + in case inact of InactiveRef old -> Map.insertWith addPair old (0, 1) m1; _ -> m1 + addPair (a1, i1) (a2, i2) = (a1 + a2, i1 + i2) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 01fdd7282a..be63d31eaa 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -1,6 +1,6 @@ module RefModel (module RefModel) where -import EbHashMap (EbHash (..), Election (..), electionSlot, PoolId (..), Slot (..)) +import EbHashMap (EbHash (..), Election (..), electionSlot, Slot (..)) import EbHashMap (EbHashMap) import qualified EbHashMap as EM import Data.Foldable (foldl', toList) @@ -13,12 +13,11 @@ import qualified Data.Map.Strict as Map import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (fromMaybe, isJust) +import Data.Semigroup (Any (..)) import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NESet import Data.These (These (..)) import Data.Word (Word16, Word64) @@ -87,10 +86,16 @@ seenFirst (SeenTwo h1) = h1 annEbHashOf :: RbHeader -> Maybe EbHash annEbHashOf = fmap annEbHash . rbAnnounce -data OfferSide = OfferBody | OfferBodyAndClosure -- §2 LstPeerOfferings / OfferSide +data OfferLevel = OfferBody | OfferBodyAndClosure -- §2 LstPeerOfferings / OfferLevel deriving (Eq, Ord, Show) -data CertSide = CertSide HeaderHash EbHash -- §2 LstPeerOfferings / CertSide +newtype LeiosNotifySide = LeiosNotifySide OfferLevel -- §2 LstPeerOfferings / LeiosNotifySide + deriving (Eq, Ord, Show) + +instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings + (<>) = max + +data ChainSyncSide = ChainSyncSide HeaderHash -- §2 LstPeerOfferings / ChainSyncSide deriving (Eq, Show) data Job = Job (NonEmpty TxHash) ByteCount -- §2 Job (ordered txs + byte size) @@ -105,14 +110,13 @@ jobByteSize (Job _ n) = n newtype OutstandingDiskWritesLessOne = OutstandingDiskWritesLessOne Word16 -- §2 AwaitingTxs: one less than the closure's outstanding DiskWrites deriving (Eq, Ord, Show) -data WantState -- §2 LstWanted / WantState - = AwaitingBody EbHash ByteCount ByteCount - | AwaitingTxs EbHash (These (NEMap JobId Job) OutstandingDiskWritesLessOne) +data WantState -- §2 LstWanted / WantState (per-EB; keyed by EbHash in the EbHashMap) + = AwaitingBody ByteCount ByteCount + | AwaitingTxs (These (NEMap JobId Job) OutstandingDiskWritesLessOne) deriving (Eq, Show) -wantEb :: WantState -> EbHash -wantEb (AwaitingBody eh _ _) = eh -wantEb (AwaitingTxs eh _) = eh +instance Semigroup WantState where -- §2 LstWanted: a shared EB keeps its existing fetch progress + a <> _ = a mkTxsState :: Map JobId Job -> Word16 -> Maybe (These (NEMap JobId Job) OutstandingDiskWritesLessOne) -- §2 AwaitingTxs payload; Nothing ⇒ closure fully fetched and persisted mkTxsState jobs writes = case (NEMap.nonEmptyMap jobs, writes) of @@ -136,14 +140,14 @@ decTxsState t = case txsWrites t of 0 -> error "decTxsState: a LevDiskDone arrived with no outstanding write" n -> mkTxsState (txsFetch t) (n - 1) -setTxs :: Election -> EbHash -> Map JobId Job -> Word16 -> St -> St -- §2 LstWanted AwaitingTxs (cleared when nothing is outstanding) -setTxs el eh jobs writes st = case mkTxsState jobs writes of - Just t -> setWant el (AwaitingTxs eh t) st - Nothing -> removeWant el st +setTxs :: EbHash -> Map JobId Job -> Word16 -> St -> St -- §2 LstWanted AwaitingTxs (callers always pass ≥ 1 outstanding write) +setTxs eh jobs writes st = case mkTxsState jobs writes of + Just t -> updateWant eh (\_ -> Just (AwaitingTxs t)) st + Nothing -> error "setTxs: no outstanding writes (completion is handled only by decWrite)" data Req -- §2 LstPeerInflight / Req - = ReqBody Election EbHash ByteCount ByteCount -- bodySize and closureSize, for validation - | ReqJob Election EbHash JobId Job -- the job itself, for validation + = ReqBody EbHash ByteCount ByteCount -- bodySize and closureSize, for validation + | ReqJob EbHash JobId Job -- the job itself, for validation deriving (Eq, Ord, Show) data PeerInfo = PeerInfo { peerClass :: Class, peerPhase :: Phase } -- §2 LstPeerPresent @@ -159,10 +163,12 @@ data Notification -- §2 LstPeerNotifyQueue data St = St { stFirstAnnouncements :: Map Election AnnState -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: Map Peer (Map Election AnnSeen) -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: Map Peer (Map Election (These CertSide OfferSide)) -- §2 LstPeerOfferings + , stPeerOfferings :: Map Peer (EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide)) -- §2 LstPeerOfferings , stPeerOfferGates :: Map Peer (EbHashMap () ()) -- §2 LstPeerOfferGates , stPeerNotifyQueue :: Map Peer (Set Notification, Int) -- §2 LstPeerNotifyQueue - , stWanted :: Map Election WantState -- §2 LstWanted + , stWanted :: EbHashMap WantState () -- §2 LstWanted + , stVolatileBody :: EbHashMap () () -- §2 LstVolatileBody + , stVolatileClosure :: EbHashMap () () -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) , stCertified :: Map Election (HeaderHash, EbHash) -- §2 LstCertified , stPeerInflight :: Map Peer (Seq Req) -- §2 LstPeerInflight , stPeerPresent :: Map Peer PeerInfo -- §2 LstPeerPresent @@ -170,7 +176,7 @@ data St = St deriving (Eq, Show) emptySt :: St -- BEH-Startup -emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty +emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty EM.empty EM.empty EM.empty Map.empty Map.empty Map.empty data Env = Env { envStakeMaxActiveEbs :: Int -- §2 stakeMaxActiveEbs @@ -215,8 +221,8 @@ data WireMsg -- §2 Wire messages = MsgLeiosNotificationRequestNext | MsgLeiosBlockAnnouncement RbHeader | MsgLeiosBlockEquivocationProof (Maybe RbHeader) RbHeader - | MsgLeiosBlockOffer Election EbHash - | MsgLeiosBlockTxsOffer Election EbHash + | MsgLeiosBlockOffer EbHash + | MsgLeiosBlockTxsOffer EbHash | MsgLeiosBlockRequest EbHash | MsgLeiosBlock EbHash Body | MsgLeiosBlockTxsRequest EbHash (NonEmpty TxHash) @@ -239,8 +245,8 @@ data Stimulus -- §2 Stimuli deriving (Eq, Show) data DiskWrite -- §2 disk store interface (writes; each yields one LevDiskDone) - = WriteBody Election Body - | WriteClosure Election EbHash [Tx] + = WriteBody Body + | WriteClosure EbHash [Tx] deriving (Eq, Show) data DiskOp -- §2 disk store interface (scheduled actions) @@ -255,6 +261,7 @@ data Offence -- §3 disconnect reasons (c | AnnouncementBound -- re-announced, or exceeded the per-peer two-first-announcements bound | BogusEquivocationProof -- did not prove a genuine equivocation | UnannouncedOffer -- offered an EB the peer never first-announced + | RedundantOffer -- an offer that raised no EB's LeiosNotify level | CertConflict -- cert for a HeaderHash conflicting with our validated cert | BodyMismatch -- body disagrees with the request (hash / size / closure size) | TxsMismatch -- closure txs disagree with the requested job (content or order) @@ -290,46 +297,39 @@ activeEbs :: St -> Peer -> Set EbHash -- §2 activeEbs · NEEDS-TO-B activeEbs st peer = Set.fromList (map reqEb (toList (inflightOf st peer))) reqEb :: Req -> EbHash -reqEb (ReqBody _ eh _ _) = eh -reqEb (ReqJob _ eh _ _) = eh - -reqElection :: Req -> Election -reqElection (ReqBody el _ _ _) = el -reqElection (ReqJob el _ _ _) = el +reqEb (ReqBody eh _ _) = eh +reqEb (ReqJob eh _ _) = eh jobInflightPeers :: St -> EbHash -> JobId -> Int -- §2 jobInflightPeers · NEEDS-TO-BE-INCREMENTAL: (EbHash,JobId)↦in-flight-peer-count index jobInflightPeers st eh j = length [ () | (_, sq) <- Map.toList (stPeerInflight st) - , ReqJob _ eh' j' _ <- toList sq + , ReqJob eh' j' _ <- toList sq , eh' == eh, j' == j ] peerSharingInFlightBytes :: St -> Peer -> EbHash -> ByteCount -- §2 peerSharingInFlightBytes · NEEDS-TO-BE-INCREMENTAL: per-(peer,EbHash) in-flight byte total peerSharingInFlightBytes st peer eh = sum [ jobByteSize job - | ReqJob _ eh' _ job <- toList (inflightOf st peer), eh' == eh ] + | ReqJob eh' _ job <- toList (inflightOf st peer), eh' == eh ] -jobBytes :: St -> Election -> EbHash -> JobId -> ByteCount -jobBytes st el _ j = - case Map.lookup el (stWanted st) of - Just (AwaitingTxs _ t) -> maybe 0 jobByteSize (Map.lookup j (txsFetch t)) +jobBytes :: St -> EbHash -> JobId -> ByteCount +jobBytes st eh j = + case wantStateOf st eh of + Just (AwaitingTxs t) -> maybe 0 jobByteSize (Map.lookup j (txsFetch t)) _ -> 0 -wantedStateOf :: St -> EbHash -> Maybe (Election, WantState) -- §2 LstWanted · NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦Election index -wantedStateOf st eh = - case [ (el, ws) | (el, ws) <- Map.toList (stWanted st), wantEb ws == eh ] of - (x : _) -> Just x - [] -> Nothing +wantStateOf :: St -> EbHash -> Maybe WantState -- §2 LstWanted +wantStateOf st eh = (\(EM.RefCounts _ _ ws) -> ws) <$> EM.lookupEb eh (stWanted st) + +wantsEh :: St -> EbHash -> Bool -- §2 LstWanted +wantsEh st eh = isJust (EM.lookupEb eh (stWanted st)) -wants :: St -> Election -> EbHash -> Bool -wants st el eh = case Map.lookup el (stWanted st) of - Just ws -> wantEb ws == eh - Nothing -> False +wantedEbs :: St -> [EbHash] -- §2 LstWanted · NEEDS-TO-BE-INCREMENTAL: maintained wanted-EB set +wantedEbs st = let EM.EbHashMap ebs _ = stWanted st in Map.keys (Map.filter (\(EM.RefCounts act _ _) -> 0 < act) ebs) -offeredEb :: St -> Peer -> Election -> These CertSide OfferSide -> Maybe EbHash -- §2 LstPeerOfferings -offeredEb st peer el side = case side of - This (CertSide _ eh) -> Just eh - These (CertSide _ eh) _ -> Just eh - That _ -> firstAnnouncedEb st peer el +electionsNaming :: EbHash -> St -> [Election] -- §2 LstWanted reverse EbHash↦Elections · NEEDS-TO-BE-INCREMENTAL: maintained reverse index +electionsNaming eh st = + let EM.EbHashMap _ els = stWanted st + in [ el | (el, EM.Refs _ act _) <- Map.toList els, act == eh ] firstAnnouncedEb :: St -> Peer -> Election -> Maybe EbHash -- §2 LstPeerFirstAnnouncements firstAnnouncedEb st peer el = do @@ -337,12 +337,16 @@ firstAnnouncedEb st peer el = do seen <- Map.lookup el perPeer annEbHashOf (seenFirst seen) -electionOf :: St -> Peer -> EbHash -> Maybe (NESet Election) -- §2 electionOf (first-announced only) · NEEDS-TO-BE-INCREMENTAL: per-peer reverse EbHash↦Elections index -electionOf st peer eh = - NESet.nonEmptySet $ Set.fromList - [ el - | (el, seen) <- Map.toList (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st))) - , annEbHashOf (seenFirst seen) == Just eh ] +electionsFirstAnnouncing :: St -> Peer -> EbHash -> [Election] -- §2 LstPeerFirstAnnouncements reverse · NEEDS-TO-BE-INCREMENTAL: per-peer reverse EbHash↦Elections index +electionsFirstAnnouncing st peer eh = + [ el + | (el, seen) <- Map.toList (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st))) + , annEbHashOf (seenFirst seen) == Just eh ] + +youngestAnnouncedSlot :: St -> Peer -> EbHash -> Maybe Slot -- BEH-NotifyServe staleness +youngestAnnouncedSlot st peer eh = case map electionSlot (electionsFirstAnnouncing st peer eh) of + [] -> Nothing + ss -> Just (maximum ss) offerersBody :: St -> EbHash -> Set Peer -- §2 offerersBody · BEH-BodyFetch offerersBody st eh = offerersAtLeast st eh OfferBody @@ -350,29 +354,23 @@ offerersBody st eh = offerersAtLeast st eh OfferBody offerersClosure :: St -> EbHash -> Set Peer -- §2 offerersClosure · BEH-ClosureFetch offerersClosure st eh = offerersAtLeast st eh OfferBodyAndClosure -offerersAtLeast :: St -> EbHash -> OfferSide -> Set Peer -- NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦offering-peers index +offerersAtLeast :: St -> EbHash -> OfferLevel -> Set Peer -- NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦offering-peers index offerersAtLeast st eh need = Set.fromList [ peer - | (peer, els) <- Map.toList (stPeerOfferings st) - , (el, side) <- Map.toList els - , offeredEb st peer el side == Just eh - , offerLevelAtLeast side need ] + | (peer, m) <- Map.toList (stPeerOfferings st) + , effectiveOffer m eh >= Just need ] -offerLevelAtLeast :: These CertSide OfferSide -> OfferSide -> Bool -offerLevelAtLeast side need = case offerLevel side of - Just lvl -> lvl >= need - Nothing -> False - -offerLevel :: These CertSide OfferSide -> Maybe OfferSide -offerLevel (This _) = Nothing -offerLevel (That lvl) = Just lvl -offerLevel (These _ lvl) = Just lvl +effectiveOffer :: EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide) -> EbHash -> Maybe OfferLevel -- §2 LstPeerOfferings effective offer +effectiveOffer m eh = case EM.lookupEb eh m of + Just (EM.RefCounts a _ (notify, Any chain)) | a > 0 -> max (unwrap <$> notify) (if chain then Just OfferBodyAndClosure else Nothing) + _ -> Nothing + where + unwrap (LeiosNotifySide lvl) = lvl offeredWanted :: St -> Peer -> [EbHash] -- NEEDS-TO-BE-INCREMENTAL: per-peer offered∩wanted set offeredWanted st peer = [ eh - | ws <- Map.elems (stWanted st) - , let eh = wantEb ws + | eh <- wantedEbs st , peer `Set.member` offerersBody st eh || peer `Set.member` offerersClosure st eh ] fetchPriorityOrder :: St -> [EbHash] -> [EbHash] -- BEH-FetchPriority · NEEDS-TO-BE-INCREMENTAL: maintained priority order, not a per-decision re-sort @@ -383,11 +381,11 @@ newtype NotificationPriority = NotificationPriority Word64 priorityKey :: St -> EbHash -> (NotificationPriority, Slot) priorityKey st eh = - case wantedStateOf st eh of - Just (el, _) - | isCertifiedEb st el eh -> (0, electionSlot el) - | otherwise -> (1, invertSlot (electionSlot el)) - Nothing -> (2, Slot 0) + case electionsNaming eh st of + [] -> (2, Slot 0) + els -> case [ electionSlot el | el <- els, isCertifiedEb st el eh ] of + (s : _) -> (0, s) + [] -> (1, invertSlot (maximum (map electionSlot els))) isCertifiedEb :: St -> Election -> EbHash -> Bool isCertifiedEb st el eh = case Map.lookup el (stCertified st) of @@ -416,25 +414,25 @@ admittedEbs env st peer cls = decideForEb :: Env -> St -> Peer -> Class -> EbHash -> [Req] -- §3 Body · Stake closure · PeerShare closure decideForEb env st peer cls eh = - case wantedStateOf st eh of - Just (el, AwaitingBody _ bs cs) | peer `Set.member` offerersBody st eh -> - [ ReqBody el eh bs cs | not (inflightHas st peer (ReqBody el eh bs cs)) ] - Just (el, AwaitingTxs _ t) | peer `Set.member` offerersClosure st eh -> + case wantStateOf st eh of + Just (AwaitingBody bs cs) | peer `Set.member` offerersBody st eh -> + [ ReqBody eh bs cs | not (inflightHas st peer (ReqBody eh bs cs)) ] + Just (AwaitingTxs t) | peer `Set.member` offerersClosure st eh -> case cls of StakeSampled -> - [ ReqJob el eh j job + [ ReqJob eh j job | (j, job) <- Map.toList (txsFetch t) - , not (inflightHas st peer (ReqJob el eh j job)) ] - PeerSharingSampled -> peerShareJobs env st peer el eh (txsFetch t) + , not (inflightHas st peer (ReqJob eh j job)) ] + PeerSharingSampled -> peerShareJobs env st peer eh (txsFetch t) _ -> [] -peerShareJobs :: Env -> St -> Peer -> Election -> EbHash -> Map JobId Job -> [Req] -- §3 PeerShare closure · BEH-ClosureFetch -peerShareJobs env st peer el eh jobs = +peerShareJobs :: Env -> St -> Peer -> EbHash -> Map JobId Job -> [Req] -- §3 PeerShare closure · BEH-ClosureFetch +peerShareJobs env st peer eh jobs = let budget = envPeerSharingClosureByteLimit env - peerSharingInFlightBytes st peer eh candidates = sortOn (\(j, _) -> (jobInflightPeers st eh j, frontSkewKey j)) [ (j, job) | (j, job) <- Map.toList jobs - , not (inflightHas st peer (ReqJob el eh j job)) ] - in takeWhileBudget budget [ (jobByteSize job, ReqJob el eh j job) | (j, job) <- candidates ] + , not (inflightHas st peer (ReqJob eh j job)) ] + in takeWhileBudget budget [ (jobByteSize job, ReqJob eh j job) | (j, job) <- candidates ] frontSkewKey :: JobId -> Word64 -- §3 Job ordering (frontSkew) frontSkewKey (JobId j) = j @@ -462,6 +460,8 @@ batchBySize limit (x : xs) = go [x] (txRefSize x) xs hashes :: [Tx] -> Set TxHash hashes = Set.fromList . map txHash +----- + step :: Monad m => Ifaces m -> Env -> Time -> Stimulus -> St -> m (St, [Effect]) -- §3 step ifs env now stim st = case stim of LevWiredMsg peer msg -> stepWired ifs env now peer msg st @@ -484,8 +484,8 @@ stepWired ifs env now peer msg st MsgLeiosNotificationRequestNext -> hRequestNext env peer st MsgLeiosBlockAnnouncement h -> hAnnouncement ifs env now peer h st MsgLeiosBlockEquivocationProof m1 h2 -> hEquivProof env peer m1 h2 st - MsgLeiosBlockOffer el eh -> hOffer env now peer el eh OfferBody st - MsgLeiosBlockTxsOffer el eh -> hOffer env now peer el eh OfferBodyAndClosure st + MsgLeiosBlockOffer eh -> hOffer env now peer eh (LeiosNotifySide OfferBody) st + MsgLeiosBlockTxsOffer eh -> hOffer env now peer eh (LeiosNotifySide OfferBodyAndClosure) st MsgLeiosBlockRequest eh -> hServeBody ifs env now peer eh st MsgLeiosBlock eh body -> hBlock ifs env now peer eh body st MsgLeiosBlockTxsRequest eh txs -> hServeTxs ifs env now peer eh txs st @@ -501,8 +501,7 @@ hAnnouncement ifs env now peer h st = case rbAnnounce h of Nothing -> pure (st, [Disconnect peer AnnouncementBound]) Just st1 -> do txCacheNoteAnnouncement (ifTxc ifs) (annEbHash ann) - (st2, fx) <- centralAnnounce ifs env now h st1 - pure (st2, fx) + centralAnnounce ifs env now h (copyAnnIntoOfferings peer (rbElection h) st1) hEquivProof :: Monad m => Env -> Peer -> Maybe RbHeader -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockEquivocationProof hEquivProof env peer mh1 h2 st = @@ -551,13 +550,22 @@ centralEquiv env el h1 h2 st = ensureWantedBodyAnn :: St -> Election -> RbHeader -> St ensureWantedBodyAnn st el h = case rbAnnounce h of - Just a -> setWant el (AwaitingBody (annEbHash a) (annBodySize a) (annClosureSize a)) st + Just a -> wantBody el (annEbHash a) (annBodySize a) (annClosureSize a) st Nothing -> st -hOffer :: Monad m => Env -> Time -> Peer -> Election -> EbHash -> OfferSide -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer -hOffer env now peer el eh lvl st = case recordedFirst st peer el of - Just h | annEbHashOf h == Just eh -> considerFetchAfter env now (raiseOffer peer (NESet.singleton el) lvl st) [] - _ -> pure (st, [Disconnect peer UnannouncedOffer]) +hOffer :: Monad m => Env -> Time -> Peer -> EbHash -> LeiosNotifySide -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer +hOffer env now peer eh lvl st = case electionsFirstAnnouncing st peer eh of + [] -> pure (st, [Disconnect peer UnannouncedOffer]) + els -> case notifyOf (raiseOffer els st) of + Nothing -> pure (st, [Disconnect peer RedundantOffer]) + Just st' -> considerFetchAfter env now st' [] + where + raiseOffer els0 s = foldl' (\acc el -> anchorOffer peer el eh acc) s els0 + notifyOf s = + let perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings s)) + bump (notify, chain) | notify >= Just lvl = Nothing + | otherwise = Just (notify <> Just lvl, chain) + in (\m -> s { stPeerOfferings = Map.insert peer m (stPeerOfferings s) }) <$> EM.updateEb eh bump perPeer hRollForward :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> Maybe AnnouncementTriple -> St -> m (St, [Effect]) -- BEH-Offers / BEH-Wanting · §3 LevRollForward hRollForward ifs env now peer h pe st = do @@ -577,14 +585,16 @@ rollForwardCert peer at st = Nothing -> False in if conflict then (st, [Disconnect peer CertConflict]) - else (recordCertSide peer el (atHeaderHash at) (atEbHash at) st, []) - -recordCertSide :: Peer -> Election -> HeaderHash -> EbHash -> St -> St -- §3 LevRollForward CertSide -recordCertSide peer el hh eh st = - st { stPeerOfferings = Map.insert peer (Map.insert el side perPeer) (stPeerOfferings st) } + else (recordChainSyncSide peer el (atHeaderHash at) (atEbHash at) st, []) + +recordChainSyncSide :: Peer -> Election -> HeaderHash -> EbHash -> St -> St -- §3 LevRollForward cert bit +recordChainSyncSide peer el hh eh st = + case EM.lookupElection el perPeer of + Just (EM.Refs EM.NoInactiveRef _ _) -> st + Just (EM.Refs (EM.InactiveRef _) _ _) -> st + _ -> st { stPeerOfferings = Map.insert peer (EM.supersede el eh (Nothing, Any True) (Just (ChainSyncSide hh)) perPeer) (stPeerOfferings st) } where - perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferings st)) - side = These (CertSide hh eh) OfferBodyAndClosure + perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)) hRequestNext :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotificationRequestNext hRequestNext env peer st = @@ -644,8 +654,8 @@ notifyElection (NotifyBlockTxsOffer el _) = el notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot (youngest, for a multi-election EbHash offer) notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) notifyMsgSlot _ _ (MsgLeiosBlockEquivocationProof _ h2) = Just (electionSlot (rbElection h2)) -notifyMsgSlot _ _ (MsgLeiosBlockOffer el _) = Just (electionSlot el) -notifyMsgSlot _ _ (MsgLeiosBlockTxsOffer el _) = Just (electionSlot el) +notifyMsgSlot st peer (MsgLeiosBlockOffer eh) = youngestAnnouncedSlot st peer eh +notifyMsgSlot st peer (MsgLeiosBlockTxsOffer eh) = youngestAnnouncedSlot st peer eh notifyMsgSlot _ _ _ = Nothing notifyStale :: Env -> Slot -> Bool -- BEH-NotifyServe staleness: slot-difference (as a duration) exceeds notifyStaleHorizon @@ -658,8 +668,8 @@ sendNotification peer n st = case n of eh = maybe (EbHash 0) annEbHash (rbAnnounce h) in (openGate peer el eh st, [Send peer (MsgLeiosBlockAnnouncement h)]) NotifyEquivProof m1 h2 -> (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) - NotifyBlockOffer el eh -> (st, [Send peer (MsgLeiosBlockOffer el eh)]) - NotifyBlockTxsOffer el eh -> (st, [Send peer (MsgLeiosBlockTxsOffer el eh)]) + NotifyBlockOffer _ eh -> (st, [Send peer (MsgLeiosBlockOffer eh)]) + NotifyBlockTxsOffer _ eh -> (st, [Send peer (MsgLeiosBlockTxsOffer eh)]) openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates openGate peer el eh st = @@ -668,12 +678,12 @@ openGate peer el eh st = hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock hBlock ifs env now peer eh body st = case frontReq st peer of - Just (ReqBody el eh' bs cs) | eh' == eh -> + Just (ReqBody eh' bs cs) | eh' == eh -> let st1 = popFront peer st closureBytes = sum (map txRefSize (bodyTxlist body)) in if bodyEbHash body /= eh || bodyActualSize body /= bs || closureBytes /= cs then pure (st1, [Disconnect peer BodyMismatch]) - else if not (wants st el eh) + else if not (wantsEh st eh) then considerFetchAfter env now st1 [] else do let txrefs = bodyTxlist body @@ -685,25 +695,25 @@ hBlock ifs env now peer eh body st = case frontReq st peer of toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = hits ++ memHs - writes = SubmitDisk (Write (WriteBody el body)) - : [ SubmitDisk (Write (WriteClosure el eh copied)) | not (null copied) ] - st2 = setTxs el eh jobsMap (fromIntegral (length writes)) st1 + writes = SubmitDisk (Write (WriteBody body)) + : [ SubmitDisk (Write (WriteClosure eh copied)) | not (null copied) ] + st2 = setTxs eh jobsMap (fromIntegral (length writes)) st1 considerFetchAfter env now st2 writes _ -> pure (st, [Disconnect peer UnsolicitedResponse]) hBlockTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> [Tx] -> St -> m (St, [Effect]) -- BEH-Responses · §3 LevBlockTxs hBlockTxs ifs env now peer eh txs st = case frontReq st peer of - Just (ReqJob el eh' j job) | eh' == eh -> + Just (ReqJob eh' j job) | eh' == eh -> let st1 = popFront peer st in if map txHash txs /= NE.toList (jobTxs job) then pure (st1, [Disconnect peer TxsMismatch]) else do txCacheOnAcquire (ifTxc ifs) txs - let writes = [SubmitDisk (Write (WriteClosure el eh txs))] - case Map.lookup el (stWanted st1) of - Just (AwaitingTxs web t) | web == eh -> + let writes = [SubmitDisk (Write (WriteClosure eh txs))] + case wantStateOf st1 eh of + Just (AwaitingTxs t) -> let jobs' = Map.delete j (txsFetch t) - st2 = setTxs el eh jobs' (txsWrites t + 1) st1 + st2 = setTxs eh jobs' (txsWrites t + 1) st1 in considerFetchAfter env now st2 writes _ -> considerFetchAfter env now st1 writes _ -> pure (st, [Disconnect peer UnsolicitedResponse]) @@ -727,14 +737,14 @@ hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st = do let st1 = setCertified el (hh, eh) st done <- isComplete ifs eh let st2 | belowTip env el = st1 - | done = removeWant el st1 - | otherwise = ensureWantedBody st1 el eh bs cs + | done = removeWantEl el st1 + | otherwise = supersedeWant el eh bs cs st1 considerFetchAfter env now st2 [] hPeerAdd :: Monad m => Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd hPeerAdd peer cls st = pure ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) - , stPeerOfferings = Map.insert peer Map.empty (stPeerOfferings st) } + , stPeerOfferings = Map.insert peer EM.empty (stPeerOfferings st) } , [] ) hPeerWindDown :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerWindDown @@ -757,19 +767,33 @@ hTimer peer req st = pure (st, [Disconnect peer RequestTimeout | inflightHas st hDiskDone :: Monad m => Ifaces m -> Env -> Time -> DiskWrite -> St -> m (St, [Effect]) -- §3 LevDiskDone · BEH-Completion hDiskDone _ifs _env _now w st = case w of - WriteBody el body -> let (st1, fx1) = enqueueBodyOffers el (bodyEbHash body) st - (st2, fx2) = decWrite el (bodyEbHash body) st1 - in pure (st2, fx1 ++ fx2) - WriteClosure el eh _ -> pure (decWrite el eh st) - -decWrite :: Election -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) -decWrite el eh st = case Map.lookup el (stWanted st) of - Just (AwaitingTxs eh' t) | eh' == eh -> case decTxsState t of - Just t' -> (setWant el (AwaitingTxs eh t') st, []) - Nothing -> let (st', fx) = enqueueClosureOffers el eh (removeWant el st) - in (st', NotifyVotingAndChainSel el eh : fx) + WriteBody body -> + let eh = bodyEbHash body + els = electionsNaming eh st + st0 = st { stVolatileBody = addVolatile eh els (stVolatileBody st) } + (st1, fx1) = case youngestElection els of + Just el -> enqueueBodyOffers el eh st0 + Nothing -> (st0, []) + (st2, fx2) = decWrite eh st1 + in pure (st2, fx1 ++ fx2) + WriteClosure eh _ -> pure (decWrite eh st) + +decWrite :: EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) +decWrite eh st = case wantStateOf st eh of + Just (AwaitingTxs t) -> case decTxsState t of + Just t' -> (updateWant eh (\_ -> Just (AwaitingTxs t')) st, []) + Nothing -> completeEb eh st _ -> (st, []) +completeEb :: EbHash -> St -> (St, [Effect]) -- BEH-Completion (per-EbHash; fan out to every interested election) +completeEb eh st = + let els = electionsNaming eh st + st0 = st { stVolatileClosure = addVolatile eh els (stVolatileClosure st) } + (st1, fx) = case youngestElection els of + Just el -> enqueueClosureOffers el eh (removeWantEb eh st0) + Nothing -> (removeWantEb eh st0, []) + in (st1, [ NotifyVotingAndChainSel el eh | el <- els ] ++ fx) + hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced hImmTipAdvanced env st = let s = envImmutableTip env @@ -784,8 +808,7 @@ hSelfIssued ifs env now h body st = case rbAnnounce h of Nothing -> pure (st, []) Just ann -> do (st1, fx) <- centralAnnounce ifs env now h st - let el = rbElection h - eh = annEbHash ann + let eh = annEbHash ann txrefs = bodyTxlist body txhs = Set.fromList (map txRefHash txrefs) memHs <- mempoolQueryPresent (ifMem ifs) txhs @@ -794,9 +817,9 @@ hSelfIssued ifs env now h body st = case rbAnnounce h of toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = memHs - writes = SubmitDisk (Write (WriteBody el body)) - : [ SubmitDisk (Write (WriteClosure el eh copied)) | not (null copied) ] - st2 = setTxs el eh jobsMap (fromIntegral (length writes)) st1 + writes = SubmitDisk (Write (WriteBody body)) + : [ SubmitDisk (Write (WriteClosure eh copied)) | not (null copied) ] + st2 = setTxs eh jobsMap (fromIntegral (length writes)) st1 pure (st2, fx ++ writes) considerFetching :: Monad m => Env -> Time -> St -> m (St, [Effect]) -- §3 consider-fetching · NEEDS-TO-BE-INCREMENTAL: reconsider only the affected peer(s)/EB, not every Active peer @@ -821,8 +844,8 @@ sendReq :: St -> Time -> Peer -> Req -> [Effect] sendReq st now peer r = [Send peer (reqWire st r), SetTimer peer r now] reqWire :: St -> Req -> WireMsg -reqWire _ (ReqBody _ eh _ _) = MsgLeiosBlockRequest eh -reqWire _ (ReqJob _ eh _ job) = MsgLeiosBlockTxsRequest eh (jobTxs job) +reqWire _ (ReqBody eh _ _) = MsgLeiosBlockRequest eh +reqWire _ (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobTxs job) frontReq :: St -> Peer -> Maybe Req frontReq st peer = case inflightOf st peer of @@ -833,11 +856,20 @@ popFront :: Peer -> St -> St popFront peer st = st { stPeerInflight = Map.adjust dropFront peer (stPeerInflight st) } where dropFront sq = case sq of _ :<| rest -> rest; Empty -> Empty -setWant :: Election -> WantState -> St -> St -setWant el ws st = st { stWanted = Map.insert el ws (stWanted st) } +wantBody :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (announcement; keep existing progress if already wanted) +wantBody el eh bs cs st = st { stWanted = EM.upsert eh el (AwaitingBody bs cs) () (stWanted st) } + +supersedeWant :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (cert validated; once per election) +supersedeWant el eh bs cs st = st { stWanted = EM.supersede el eh (AwaitingBody bs cs) () (stWanted st) } -removeWant :: Election -> St -> St -removeWant el st = st { stWanted = Map.delete el (stWanted st) } +updateWant :: EbHash -> (WantState -> Maybe WantState) -> St -> St -- §2 LstWanted (in-place per-EB payload update; no-op if absent) +updateWant eh f st = st { stWanted = fromMaybe (stWanted st) (EM.updateEb eh f (stWanted st)) } + +removeWantEl :: Election -> St -> St -- §2 LstWanted (drop an election's references) +removeWantEl el st = st { stWanted = EM.deleteElection el (stWanted st) } + +removeWantEb :: EbHash -> St -> St -- §2 LstWanted (drop every election actively wanting eh) +removeWantEb eh st = st { stWanted = foldl' (flip EM.deleteElection) (stWanted st) (electionsNaming eh st) } isComplete :: Monad m => Ifaces m -> EbHash -> m Bool -- BEH-Completion (restart-time check only, in LevCertValidated) isComplete ifs eh = do @@ -852,30 +884,37 @@ isComplete ifs eh = do setCertified :: Election -> (HeaderHash, EbHash) -> St -> St setCertified el v st = st { stCertified = Map.insert el v (stCertified st) } -ensureWantedBody :: St -> Election -> EbHash -> ByteCount -> ByteCount -> St -ensureWantedBody st el eh bs cs = case Map.lookup el (stWanted st) of - Just _ -> st - Nothing -> setWant el (AwaitingBody eh bs cs) st - -enqueueOffer :: Notification -> Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion · NEEDS-TO-BE-INCREMENTAL: (Election,EbHash)↦gated-downstream-peers index -enqueueOffer notif el eh st = +enqueueOffer :: Notification -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion · NEEDS-TO-BE-INCREMENTAL: EbHash↦gated-downstream-peers index +enqueueOffer notif eh st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer notif s in (s', fx ++ fx')) (st, []) gated where - gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), (EM.activeRef <$> EM.lookupElection el gates) == Just eh ] + gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), isJust (EM.lookupEb eh gates) ] enqueueBodyOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion -enqueueBodyOffers el eh = enqueueOffer (NotifyBlockOffer el eh) el eh +enqueueBodyOffers el eh = enqueueOffer (NotifyBlockOffer el eh) eh enqueueClosureOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion -enqueueClosureOffers el eh = enqueueOffer (NotifyBlockTxsOffer el eh) el eh +enqueueClosureOffers el eh = enqueueOffer (NotifyBlockTxsOffer el eh) eh + +addVolatile :: EbHash -> [Election] -> EbHashMap () () -> EbHashMap () () -- §2 LstVolatileBody/LstVolatileClosure +addVolatile eh els m = foldl' (\acc el -> EM.upsert eh el () () acc) m els + +youngestElection :: [Election] -> Maybe Election -- §3 offer representative (youngest naming election) +youngestElection [] = Nothing +youngestElection els = Just (maximumBy (comparing electionSlot) els) + +heldIn :: EbHash -> EbHashMap a b -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership +heldIn eh m = isJust (EM.lookupEb eh m) pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete pruneBelow s st = st { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) - , stWanted = pruneElectionMap s (stWanted st) + , stWanted = EM.pruneElections (\el -> electionSlot el < s) (stWanted st) + , stVolatileBody = EM.pruneElections (\el -> electionSlot el < s) (stVolatileBody st) + , stVolatileClosure = EM.pruneElections (\el -> electionSlot el < s) (stVolatileClosure st) , stCertified = pruneElectionMap s (stCertified st) , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) - , stPeerOfferings = Map.map (pruneElectionMap s) (stPeerOfferings st) + , stPeerOfferings = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferings st) , stPeerOfferGates = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferGates st) } @@ -903,12 +942,17 @@ centralAnnounce _ifs env _now h st = case rbAnnounce h of Nothing -> pure (st, []) Just ann -> let el = rbElection h + eh = annEbHash ann in case Map.lookup el (stFirstAnnouncements st) of Nothing -> let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } - st2 | belowTip env el = st1 - | otherwise = setWant el (AwaitingBody (annEbHash ann) (annBodySize ann) (annClosureSize ann)) st1 - in pure (enqueueToAll (NotifyAnnouncement h) st2) + st2 = anchorVolatile el eh st1 + st3 | belowTip env el = st2 + | heldIn eh (stVolatileClosure st2) = st2 + | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 + (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 + (st5, fx') = enqueueHeldOffers el eh st4 + in pure (st5, fx ++ fx') Just (AnnOne h1) | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) | otherwise -> @@ -916,16 +960,31 @@ centralAnnounce _ifs env _now h st = case rbAnnounce h of in pure (enqueueToAll (NotifyEquivProof (Just h1) h) st1) Just (AnnTwo{}) -> pure (st, []) -raiseOffer :: Peer -> NESet Election -> OfferSide -> St -> St -- §3 LevBlockOffer raise OfferSide -raiseOffer peer els lvl st = - st { stPeerOfferings = Map.insert peer updated (stPeerOfferings st) } +anchorVolatile :: Election -> EbHash -> St -> St -- §2 LstVolatileBody/Closure: a fresh announcement extends a held EB's elections +anchorVolatile el eh st = st + { stVolatileBody = if heldIn eh (stVolatileBody st) then addVolatile eh [el] (stVolatileBody st) else stVolatileBody st + , stVolatileClosure = if heldIn eh (stVolatileClosure st) then addVolatile eh [el] (stVolatileClosure st) else stVolatileClosure st } + +enqueueHeldOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-Offers · BEH-Completion: offer a held EB to peers we are announcing it to +enqueueHeldOffers el eh st + | heldIn eh (stVolatileClosure st) = enqueueToAll (NotifyBlockTxsOffer el eh) st + | heldIn eh (stVolatileBody st) = enqueueToAll (NotifyBlockOffer el eh) st + | otherwise = (st, []) + +copyAnnIntoOfferings :: Peer -> Election -> St -> St -- BEH-Offers · §2 LstPeerOfferings +copyAnnIntoOfferings peer el st = case firstAnnouncedEb st peer el of + Just eh | offered eh -> anchorOffer peer el eh st + _ -> st + where + offered eh = isJust (EM.lookupEb eh (fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)))) + +anchorOffer :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferings +anchorOffer peer el eh st = + case EM.activeRef <$> EM.lookupElection el perPeer of + Just act | act /= eh -> st + _ -> st { stPeerOfferings = Map.insert peer (EM.upsert eh el (Nothing, Any False) Nothing perPeer) (stPeerOfferings st) } where - perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerOfferings st)) - updated = foldr (\el m -> Map.insert el (raise (Map.lookup el m)) m) perPeer (toList (NESet.toSet els)) - raise Nothing = That lvl - raise (Just (This c)) = These c lvl - raise (Just (That l)) = That (max l lvl) - raise (Just (These c l)) = These c (max l lvl) + perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)) nullIfaces :: Applicative m => Ifaces m nullIfaces = Ifaces @@ -940,8 +999,9 @@ nullIfaces = Ifaces prop_wantAnnouncementGated :: St -> Bool -- §4 Want is announcement-gated prop_wantAnnouncementGated st = - Map.keysSet (stWanted st) - `Set.isSubsetOf` (Map.keysSet (stFirstAnnouncements st) `Set.union` Map.keysSet (stCertified st)) + let EM.EbHashMap _ els = stWanted st + in Map.keysSet els + `Set.isSubsetOf` (Map.keysSet (stFirstAnnouncements st) `Set.union` Map.keysSet (stCertified st)) prop_perPeerActiveEbCap :: Env -> St -> Bool -- §4 Per-peer active-EB cap prop_perPeerActiveEbCap env st = @@ -950,17 +1010,17 @@ prop_perPeerActiveEbCap env st = prop_offersAnnouncedOrCertified :: St -> Bool -- §4 Offers are announced or certified prop_offersAnnouncedOrCertified st = and - [ case side of - This _ -> True - These _ _ -> True - That _ -> isJust (firstAnnouncedEb st peer el) - | (peer, els) <- Map.toList (stPeerOfferings st) - , (el, side) <- Map.toList els ] + [ case inact of + EM.NoInactiveRefYet -> isJust (firstAnnouncedEb st peer el) + _ -> True + | (peer, m) <- Map.toList (stPeerOfferings st) + , let EM.EbHashMap _ els = m + , (el, EM.Refs inact _ _) <- Map.toList els ] prop_inflightOffered :: St -> Bool -- §4 Client soundness (offer half) prop_inflightOffered st = and [ case r of - ReqBody _ eh _ _ -> peer `Set.member` offerersBody st eh - ReqJob _ eh _ _ -> peer `Set.member` offerersClosure st eh + ReqBody eh _ _ -> peer `Set.member` offerersBody st eh + ReqJob eh _ _ -> peer `Set.member` offerersClosure st eh | (peer, sq) <- Map.toList (stPeerInflight st) , r <- toList sq ] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index e6166712f9..1e11e9807f 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -41,11 +41,11 @@ body100 = Body (EbHash 100) [TxRef (TxHash 1) 150, TxRef (TxHash 2) 150] 200 ann :: Peer -> RbHeader -> Stimulus ann p h = LevWiredMsg p (MsgLeiosBlockAnnouncement h) -offer :: Peer -> Election -> EbHash -> Stimulus -offer p el eh = LevWiredMsg p (MsgLeiosBlockOffer el eh) +offer :: Peer -> EbHash -> Stimulus +offer p eh = LevWiredMsg p (MsgLeiosBlockOffer eh) -txsOffer :: Peer -> Election -> EbHash -> Stimulus -txsOffer p el eh = LevWiredMsg p (MsgLeiosBlockTxsOffer el eh) +txsOffer :: Peer -> EbHash -> Stimulus +txsOffer p eh = LevWiredMsg p (MsgLeiosBlockTxsOffer eh) runWith :: Ifaces Identity -> [Stimulus] -> (St, [Effect]) runWith ifs = foldl' go (emptySt, []) @@ -83,24 +83,24 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-Wanting: an announcement gates the want (AwaitingBody), no fetch yet" $ do let (st, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100] - Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + wantStateOf st (EbHash 100) @?= Just (AwaitingBody 200 300) assertBool "no request before an offer" (not (any isReq fx)) , testCase "BEH-Offers + BEH-BodyFetch: an offer for the first-announced EB issues ReqBody" $ do - let (_, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100)] + let (_, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100)] assertBool "sends MsgLeiosBlockRequest" (Send (Peer 1) (MsgLeiosBlockRequest (EbHash 100)) `elem` fx) , testCase "BEH-ChunkJobs + BEH-ClosureFetch: body then closure-offer requests the chunked job's txs" $ do - let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) - , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) ] + let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) ] [ txs | Send _ (MsgLeiosBlockTxsRequest _ txs) <- fx ] @?= [NE.fromList [TxHash 1, TxHash 2]] assertBool "want advanced to AwaitingTxs" - (case Map.lookup el100 (stWanted st) of Just AwaitingTxs{} -> True; _ -> False) + (case wantStateOf st (EbHash 100) of Just AwaitingTxs{} -> True; _ -> False) , testCase "Job: jobBytes is the real summed tx size" $ do - let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] - jobBytes st el100 (EbHash 100) (JobId 0) @?= 300 + jobBytes st (EbHash 100) (JobId 0) @?= 300 , testCase "BEH-NotifyServe: a dequeue ships the buffered announcement and opens the gate" $ do let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled @@ -174,17 +174,17 @@ tests = testGroup "Leios RefModel — Spec.md main spec" let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) ] assertBool "no disconnect" (not (any isDisconnect fx)) - Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + wantStateOf st (EbHash 100) @?= Just (AwaitingBody 200 300) , testCase "BEH-Offers: an offer for an equivocating (non-first) EB disconnects" $ do let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) - , offer (Peer 1) el100 (EbHash 101) ] + , offer (Peer 1) (EbHash 101) ] assertBool "disconnects (unannounced offer)" (Disconnect (Peer 1) UnannouncedOffer `elem` fx) , testCase "BEH-Responses: a body whose closure size mismatches the announcement disconnects" $ do let badBody = Body (EbHash 100) [TxRef (TxHash 1) 1] 200 - (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) + (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) badBody) ] assertBool "disconnects with BodyMismatch" (Disconnect (Peer 1) BodyMismatch `elem` fx) @@ -194,8 +194,8 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "disconnects with UnsolicitedResponse" (Disconnect (Peer 1) UnsolicitedResponse `elem` fx) , testCase "BEH-Responses: a tx-closure reply in the wrong order disconnects" $ do - let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) - , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlockTxs (EbHash 100) [Tx (TxHash 2) 150, Tx (TxHash 1) 150]) ] assertBool "disconnects with TxsMismatch" (Disconnect (Peer 1) TxsMismatch `elem` fx) @@ -208,30 +208,30 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-Completion: finishing a body write enqueues a body offer to gated peers" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) - , LevDiskDone (WriteBody el100 body100) ] + , LevDiskDone (WriteBody body100) ] q = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) assertBool "body offer enqueued" (Set.member (NotifyBlockOffer el100 (EbHash 100)) q) , testCase "BEH-Completion: voting + ChainSel are notified only when the last write lands (persist-gated)" $ do let txs = [Tx (TxHash 1) 150, Tx (TxHash 2) 150] - setup = [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) - , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) + setup = [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlockTxs (EbHash 100) txs) ] exposed fx = NotifyVotingAndChainSel el100 (EbHash 100) `elem` fx - (_, fx1) = run (setup ++ [ LevDiskDone (WriteBody el100 body100) ]) - (st2, fx2) = run (setup ++ [ LevDiskDone (WriteBody el100 body100) - , LevDiskDone (WriteClosure el100 (EbHash 100) txs) ]) + (_, fx1) = run (setup ++ [ LevDiskDone (WriteBody body100) ]) + (st2, fx2) = run (setup ++ [ LevDiskDone (WriteBody body100) + , LevDiskDone (WriteClosure (EbHash 100) txs) ]) assertBool "fetch-complete + first write expose nothing" (not (exposed fx1)) assertBool "last write notifies voting and ChainSel" (exposed fx2) - assertBool "and the want is cleared" (not (Map.member el100 (stWanted st2))) + assertBool "and the want is cleared" (isNothing (lookupElection el100 (stWanted st2))) , testCase "BEH-Wanting: a validated cert (no prior want) creates an AwaitingBody with the carried sizes" $ do let (st, _) = run [ LevCertValidated (AnnouncementTriple el100 (HeaderHash 10) (EbHash 100)) 200 300 ] - Map.lookup el100 (stWanted st) @?= Just (AwaitingBody (EbHash 100) 200 300) + wantStateOf st (EbHash 100) @?= Just (AwaitingBody 200 300) , testCase "§4 safety properties hold on the closure-fetch scenario" $ do - let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) el100 (EbHash 100) - , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) el100 (EbHash 100) ] + let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) ] assertBool "want announcement-gated" (prop_wantAnnouncementGated st) assertBool "per-peer active-EB cap" (prop_perPeerActiveEbCap env st) assertBool "offers announced/certified" (prop_offersAnnouncedOrCertified st) @@ -257,10 +257,10 @@ tests = testGroup "Leios RefModel — Spec.md main spec" m5 = fromMaybe m4 (updateEb ehA (Just . (<> [4])) m4) mC = supersede el3 ehC [6] () (upsert ehC el3 [5] () m5) -- supersede with active==eh combines m = supersede el4 ehD [7] () mC -- supersede before any upsert - lookupEb ehA m @?= Just (RefCount 2 [1, 2, 3, 4]) - lookupEb ehB m @?= Just (RefCount 1 [9]) - lookupEb ehC m @?= Just (RefCount 1 [5, 6]) - lookupEb ehD m @?= Just (RefCount 1 [7]) + lookupEb ehA m @?= Just (RefCounts 1 1 [1, 2, 3, 4]) -- el2 active, el1 now inactive + lookupEb ehB m @?= Just (RefCounts 1 0 [9]) + lookupEb ehC m @?= Just (RefCounts 1 0 [5, 6]) + lookupEb ehD m @?= Just (RefCounts 1 0 [7]) assertBool "invariant holds" (invariant m) ] From fea70a757700bf2cae8e5f92322aeec1b648b19b Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sat, 27 Jun 2026 19:13:26 -0400 Subject: [PATCH 05/16] WIP simplify notifications, no prioritization anymore --- .../Test/Leios/RefModel/RefModel.hs | 131 ++++++++---------- .../Test/Leios/RefModel/test/RefModelTest.hs | 22 +-- 2 files changed, 66 insertions(+), 87 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index be63d31eaa..9dd632d709 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -4,10 +4,9 @@ import EbHashMap (EbHash (..), Election (..), electionSlot, Slot (..)) import EbHashMap (EbHashMap) import qualified EbHashMap as EM import Data.Foldable (foldl', toList) -import Data.List (maximumBy, minimumBy, sortOn) +import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Ord (comparing) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Map.NonEmpty (NEMap) @@ -156,16 +155,16 @@ data PeerInfo = PeerInfo { peerClass :: Class, peerPhase :: Phase } -- §2 LstP data Notification -- §2 LstPeerNotifyQueue = NotifyAnnouncement RbHeader | NotifyEquivProof (Maybe RbHeader) RbHeader - | NotifyBlockOffer Election EbHash -- MsgLeiosBlockOffer - | NotifyBlockTxsOffer Election EbHash -- MsgLeiosBlockTxsOffer + | NotifyBlockOffer EbHash -- MsgLeiosBlockOffer + | NotifyBlockTxsOffer EbHash -- MsgLeiosBlockTxsOffer deriving (Eq, Ord, Show) data St = St { stFirstAnnouncements :: Map Election AnnState -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: Map Peer (Map Election AnnSeen) -- §2 LstPeerFirstAnnouncements , stPeerOfferings :: Map Peer (EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide)) -- §2 LstPeerOfferings - , stPeerOfferGates :: Map Peer (EbHashMap () ()) -- §2 LstPeerOfferGates - , stPeerNotifyQueue :: Map Peer (Set Notification, Int) -- §2 LstPeerNotifyQueue + , stPeerOfferGates :: Map Peer (EbHashMap (Maybe LeiosNotifySide) ()) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerNotifyQueue :: Map Peer (Seq Notification, Int) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) , stWanted :: EbHashMap WantState () -- §2 LstWanted , stVolatileBody :: EbHashMap () () -- §2 LstVolatileBody , stVolatileClosure :: EbHashMap () () -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) @@ -521,10 +520,10 @@ recordedFirst st peer el = do genuineEquiv :: RbHeader -> RbHeader -> Bool -- §3 LevBlockEquivocationProof validation genuineEquiv h1 h2 = - rbValid h1 && rbValid h2 - && isJust (rbAnnounce h1) && isJust (rbAnnounce h2) - && rbElection h1 == rbElection h2 + rbElection h1 == rbElection h2 && rbHeaderHash h1 /= rbHeaderHash h2 + && isJust (rbAnnounce h1) && isJust (rbAnnounce h2) + && rbValid h1 && rbValid h2 advancePeerToTwo :: Peer -> Election -> RbHeader -> St -> Maybe St -- §3 LstPeerFirstAnnouncements -> Two advancePeerToTwo peer el h1 st = @@ -598,58 +597,47 @@ recordChainSyncSide peer el hh eh st = hRequestNext :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotificationRequestNext hRequestNext env peer st = - let (s, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + let (s, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) in if cap >= envNotifyMaxCapacity env then pure (st, [Disconnect peer ExcessNotifyCredits]) else pure (setQueue peer (s, cap + 1) st, []) hNotifyDequeue :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotifyDequeue hNotifyDequeue env peer st = - let (s, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) - in case pickMax s of - Nothing -> error "hNotifyDequeue: LevNotifyDequeue on an empty queue" - Just (n, s') - | belowTip env (notifyElection n) -> pure (setQueue peer (s', cap) st, []) - | otherwise -> pure (sendNotification peer n (setQueue peer (s', cap - 1) st)) - -setQueue :: Peer -> (Set Notification, Int) -> St -> St + let (q, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + in case q of + Empty -> error "hNotifyDequeue: LevNotifyDequeue on an empty queue" + n :<| q' + | discard -> pure (setQueue peer (q', cap) st, []) + | otherwise -> pure (sendNotification peer n (setQueue peer (q', cap - 1) st)) + where + discard = case n of + NotifyAnnouncement h -> belowTip env (rbElection h) + NotifyEquivProof _ h2 -> belowTip env (rbElection h2) + NotifyBlockOffer eh -> not (offerable peer eh OfferBody st) + NotifyBlockTxsOffer eh -> not (offerable peer eh OfferBodyAndClosure st) + +setQueue :: Peer -> (Seq Notification, Int) -> St -> St setQueue peer v st = st { stPeerNotifyQueue = Map.insert peer v (stPeerNotifyQueue st) } -enqueue :: Notification -> (Set Notification, Int) -> (Set Notification, Int) -- BEH-NotifyServe -enqueue n (q, cap) = - let q' = Set.insert n q - in if Set.size q' > cap - then (Set.delete (minimumBy (comparing notifyRank) (Set.toList q')) q', cap) - else (q', cap) +enqueue :: Notification -> (Seq Notification, Int) -> (Seq Notification, Int) -- BEH-NotifyServe (FIFO; drop the new message when full) +enqueue n (q, cap) + | Seq.length q < cap = (q Seq.|> n, cap) + | otherwise = (q, cap) enqueueTo :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe enqueueTo peer n st = - let (q, cap) = fromMaybe (Set.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + let (q, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) (q', _) = enqueue n (q, cap) - in (setQueue peer (q', cap) st, [ NotifyEnqueue peer | Set.size q' > Set.size q ]) + in (setQueue peer (q', cap) st, [ NotifyEnqueue peer | Seq.length q' > Seq.length q ]) enqueueToAll :: Notification -> St -> (St, [Effect]) -- BEH-NotifyServe relay enqueueToAll n st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer n s in (s', fx ++ fx')) (st, []) (Map.keys (stPeerPresent st)) -pickMax :: Set Notification -> Maybe (Notification, Set Notification) -- §2 notifyPriority · NEEDS-TO-BE-INCREMENTAL: two slot-ordered queues (announcements; non-announcements) -pickMax s - | Set.null s = Nothing - | otherwise = let n = maximumBy (comparing notifyRank) (Set.toList s) in Just (n, Set.delete n s) - -notifyRank :: Notification -> (NotificationPriority, Word64) -- §2 notifyPriority (simplified; L_hdr tiers TODO) -notifyRank (NotifyAnnouncement h) = (3, slotW (rbElection h)) -notifyRank (NotifyEquivProof _ h2) = (2, slotW (rbElection h2)) -notifyRank (NotifyBlockTxsOffer el _) = (1, slotW el) -notifyRank (NotifyBlockOffer el _) = (1, slotW el) - -slotW :: Election -> Word64 -slotW (Election (Slot s) _) = s - -notifyElection :: Notification -> Election -- §2 notification's election (for BEH-ImmTipAdvance staleness) -notifyElection (NotifyAnnouncement h) = rbElection h -notifyElection (NotifyEquivProof _ h2) = rbElection h2 -notifyElection (NotifyBlockOffer el _) = el -notifyElection (NotifyBlockTxsOffer el _) = el +offerable :: Peer -> EbHash -> OfferLevel -> St -> Bool -- §2 LstPeerOfferGates: announced, and not yet offered at this level +offerable peer eh lvl st = case EM.lookupEb eh (fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st))) of + Just (EM.RefCounts _ _ sent) -> sent < Just (LeiosNotifySide lvl) + Nothing -> False notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot (youngest, for a multi-election EbHash offer) notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) @@ -668,12 +656,18 @@ sendNotification peer n st = case n of eh = maybe (EbHash 0) annEbHash (rbAnnounce h) in (openGate peer el eh st, [Send peer (MsgLeiosBlockAnnouncement h)]) NotifyEquivProof m1 h2 -> (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) - NotifyBlockOffer _ eh -> (st, [Send peer (MsgLeiosBlockOffer eh)]) - NotifyBlockTxsOffer _ eh -> (st, [Send peer (MsgLeiosBlockTxsOffer eh)]) + NotifyBlockOffer eh -> (bumpGate peer eh OfferBody st, [Send peer (MsgLeiosBlockOffer eh)]) + NotifyBlockTxsOffer eh -> (bumpGate peer eh OfferBodyAndClosure st, [Send peer (MsgLeiosBlockTxsOffer eh)]) -openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates +openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates: announcement sent (no offer yet) openGate peer el eh st = - st { stPeerOfferGates = Map.insert peer (EM.upsert eh el () () perPeer) (stPeerOfferGates st) } + st { stPeerOfferGates = Map.insert peer (EM.upsert eh el Nothing () perPeer) (stPeerOfferGates st) } + where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) + +bumpGate :: Peer -> EbHash -> OfferLevel -> St -> St -- §2 LstPeerOfferGates: record the offer level sent +bumpGate peer eh lvl st = case EM.updateEb eh (\sent -> Just (sent <> Just (LeiosNotifySide lvl))) perPeer of + Just m' -> st { stPeerOfferGates = Map.insert peer m' (stPeerOfferGates st) } + Nothing -> st where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock @@ -769,11 +763,8 @@ hDiskDone :: Monad m => Ifaces m -> Env -> Time -> DiskWrite -> St -> m (St, [Ef hDiskDone _ifs _env _now w st = case w of WriteBody body -> let eh = bodyEbHash body - els = electionsNaming eh st - st0 = st { stVolatileBody = addVolatile eh els (stVolatileBody st) } - (st1, fx1) = case youngestElection els of - Just el -> enqueueBodyOffers el eh st0 - Nothing -> (st0, []) + st0 = st { stVolatileBody = addVolatile eh (electionsNaming eh st) (stVolatileBody st) } + (st1, fx1) = enqueueBodyOffers eh st0 (st2, fx2) = decWrite eh st1 in pure (st2, fx1 ++ fx2) WriteClosure eh _ -> pure (decWrite eh st) @@ -789,9 +780,7 @@ completeEb :: EbHash -> St -> (St, [Effect]) -- BEH-Completion (per-EbHash; fan completeEb eh st = let els = electionsNaming eh st st0 = st { stVolatileClosure = addVolatile eh els (stVolatileClosure st) } - (st1, fx) = case youngestElection els of - Just el -> enqueueClosureOffers el eh (removeWantEb eh st0) - Nothing -> (removeWantEb eh st0, []) + (st1, fx) = enqueueClosureOffers eh (removeWantEb eh st0) in (st1, [ NotifyVotingAndChainSel el eh | el <- els ] ++ fx) hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced @@ -884,25 +873,15 @@ isComplete ifs eh = do setCertified :: Election -> (HeaderHash, EbHash) -> St -> St setCertified el v st = st { stCertified = Map.insert el v (stCertified st) } -enqueueOffer :: Notification -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion · NEEDS-TO-BE-INCREMENTAL: EbHash↦gated-downstream-peers index -enqueueOffer notif eh st = - foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer notif s in (s', fx ++ fx')) (st, []) gated - where - gated = [ peer | (peer, gates) <- Map.toList (stPeerOfferGates st), isJust (EM.lookupEb eh gates) ] +enqueueBodyOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) +enqueueBodyOffers eh = enqueueToAll (NotifyBlockOffer eh) -enqueueBodyOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion -enqueueBodyOffers el eh = enqueueOffer (NotifyBlockOffer el eh) eh - -enqueueClosureOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion -enqueueClosureOffers el eh = enqueueOffer (NotifyBlockTxsOffer el eh) eh +enqueueClosureOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) +enqueueClosureOffers eh = enqueueToAll (NotifyBlockTxsOffer eh) addVolatile :: EbHash -> [Election] -> EbHashMap () () -> EbHashMap () () -- §2 LstVolatileBody/LstVolatileClosure addVolatile eh els m = foldl' (\acc el -> EM.upsert eh el () () acc) m els -youngestElection :: [Election] -> Maybe Election -- §3 offer representative (youngest naming election) -youngestElection [] = Nothing -youngestElection els = Just (maximumBy (comparing electionSlot) els) - heldIn :: EbHash -> EbHashMap a b -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership heldIn eh m = isJust (EM.lookupEb eh m) @@ -951,7 +930,7 @@ centralAnnounce _ifs env _now h st = case rbAnnounce h of | heldIn eh (stVolatileClosure st2) = st2 | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 - (st5, fx') = enqueueHeldOffers el eh st4 + (st5, fx') = enqueueHeldOffers eh st4 in pure (st5, fx ++ fx') Just (AnnOne h1) | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) @@ -965,10 +944,10 @@ anchorVolatile el eh st = st { stVolatileBody = if heldIn eh (stVolatileBody st) then addVolatile eh [el] (stVolatileBody st) else stVolatileBody st , stVolatileClosure = if heldIn eh (stVolatileClosure st) then addVolatile eh [el] (stVolatileClosure st) else stVolatileClosure st } -enqueueHeldOffers :: Election -> EbHash -> St -> (St, [Effect]) -- BEH-Offers · BEH-Completion: offer a held EB to peers we are announcing it to -enqueueHeldOffers el eh st - | heldIn eh (stVolatileClosure st) = enqueueToAll (NotifyBlockTxsOffer el eh) st - | heldIn eh (stVolatileBody st) = enqueueToAll (NotifyBlockOffer el eh) st +enqueueHeldOffers :: EbHash -> St -> (St, [Effect]) -- BEH-Offers · BEH-Completion: offer a held EB to peers we are announcing it to +enqueueHeldOffers eh st + | heldIn eh (stVolatileClosure st) = enqueueToAll (NotifyBlockTxsOffer eh) st + | heldIn eh (stVolatileBody st) = enqueueToAll (NotifyBlockOffer eh) st | otherwise = (st, []) copyAnnIntoOfferings :: Peer -> Election -> St -> St -- BEH-Offers · §2 LstPeerOfferings diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 1e11e9807f..18829c3646 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -6,7 +6,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) import Data.Monoid (Sum (..)) -import qualified Data.Set as Set +import qualified Data.Sequence as Seq import Test.Tasty import Test.Tasty.HUnit @@ -115,18 +115,18 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-NotifyServe back-pressure: with no credit nothing is buffered and no NotifyEnqueue fires" $ do let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled, ann (Peer 1) hdr100 ] - q = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) - assertBool "queue empty without a credit" (Set.null q) + q = maybe Seq.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + assertBool "queue empty without a credit" (Seq.null q) assertBool "no NotifyEnqueue for Peer 2" (null [ () | NotifyEnqueue (Peer 2) <- fx ]) - , testCase "BEH-NotifyServe back-pressure: a full queue evicts the notifyPriority-min, and only the enqueue with an unoccupied credit emits NotifyEnqueue" $ do + , testCase "BEH-NotifyServe back-pressure: a full FIFO drops the overflowing (newest) message, keeping the first" $ do let setup ps = run ([ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled, credit (Peer 2) ] ++ ps) - qOf (st, _) = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + qOf (st, _) = maybe Seq.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) enqOf (_, fx) = length [ () | NotifyEnqueue (Peer 2) <- fx ] stalerFirst = setup [ ann (Peer 1) hdr100, ann (Peer 1) hdr200 ] fresherFirst = setup [ ann (Peer 1) hdr200, ann (Peer 1) hdr100 ] - qOf stalerFirst @?= Set.singleton (NotifyAnnouncement hdr200) - qOf fresherFirst @?= Set.singleton (NotifyAnnouncement hdr200) + qOf stalerFirst @?= Seq.fromList [NotifyAnnouncement hdr100] + qOf fresherFirst @?= Seq.fromList [NotifyAnnouncement hdr200] enqOf stalerFirst @?= 1 enqOf fresherFirst @?= 1 @@ -158,7 +158,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , credit (Peer 2), ann (Peer 1) hdr100 ] (st1, fx) = runIdentity (step nullIfaces envT (Time 0) (dequeue (Peer 2)) st0) assertBool "stale notification not sent" (null [ () | Send (Peer 2) _ <- fx ]) - assertBool "stale notification discarded" (maybe True (Set.null . fst) (Map.lookup (Peer 2) (stPeerNotifyQueue st1))) + assertBool "stale notification discarded" (maybe True (Seq.null . fst) (Map.lookup (Peer 2) (stPeerNotifyQueue st1))) , testCase "BEH-ImmTipAdvance: promote is prompt, GC is deferred" $ do let envT = env { envImmutableTip = Slot 7 } @@ -205,12 +205,12 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [TxHash 1, TxHash 2])) ] [ ts | Send _ (MsgLeiosBlockTxs _ ts) <- fx ] @?= [[Tx (TxHash 1) 1, Tx (TxHash 2) 1]] - , testCase "BEH-Completion: finishing a body write enqueues a body offer to gated peers" $ do + , testCase "BEH-Completion: finishing a body write enqueues a body offer" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) , LevDiskDone (WriteBody body100) ] - q = maybe Set.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) - assertBool "body offer enqueued" (Set.member (NotifyBlockOffer el100 (EbHash 100)) q) + q = maybe Seq.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) + assertBool "body offer enqueued" (NotifyBlockOffer (EbHash 100) `elem` q) , testCase "BEH-Completion: voting + ChainSel are notified only when the last write lands (persist-gated)" $ do let txs = [Tx (TxHash 1) 150, Tx (TxHash 2) 150] From ec0e17f1e9e2c4b51cbd377a11fc83cb0b39f82a Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 04:51:48 -0400 Subject: [PATCH 06/16] WIP add SlotNo to Msg*Offer to match CIP --- .../Test/Leios/RefModel/RefModel.hs | 99 ++++++++++++------- .../Test/Leios/RefModel/test/RefModelTest.hs | 6 +- 2 files changed, 64 insertions(+), 41 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 9dd632d709..cfddf66c73 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -88,12 +88,18 @@ annEbHashOf = fmap annEbHash . rbAnnounce data OfferLevel = OfferBody | OfferBodyAndClosure -- §2 LstPeerOfferings / OfferLevel deriving (Eq, Ord, Show) -newtype LeiosNotifySide = LeiosNotifySide OfferLevel -- §2 LstPeerOfferings / LeiosNotifySide - deriving (Eq, Ord, Show) - -instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings +instance Semigroup OfferLevel where -- §2 LstPeerOfferings (gate sent-level raises to the max) (<>) = max +data LeiosNotifySide = LeiosNotifySide OfferLevel Time -- §2 LstPeerOfferings: a peer's LeiosNotify offer level and when last (re)offered (RedundantOffer TTL) + deriving (Eq, Show) + +offerLevel :: LeiosNotifySide -> OfferLevel +offerLevel (LeiosNotifySide lvl _) = lvl + +instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings (tuple-Semigroup requirement; never merges two reals at runtime) + LeiosNotifySide l1 t1 <> LeiosNotifySide l2 t2 = LeiosNotifySide (max l1 l2) (max t1 t2) + data ChainSyncSide = ChainSyncSide HeaderHash -- §2 LstPeerOfferings / ChainSyncSide deriving (Eq, Show) @@ -159,18 +165,24 @@ data Notification -- §2 LstPeerNotifyQueue | NotifyBlockTxsOffer EbHash -- MsgLeiosBlockTxsOffer deriving (Eq, Ord, Show) +infixr 1 :-> +type k :-> v = Map k v + +infix 9 :& +type a :& b = EbHashMap a b + data St = St - { stFirstAnnouncements :: Map Election AnnState -- §2 LstFirstAnnouncements - , stPeerFirstAnnouncements :: Map Peer (Map Election AnnSeen) -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: Map Peer (EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide)) -- §2 LstPeerOfferings - , stPeerOfferGates :: Map Peer (EbHashMap (Maybe LeiosNotifySide) ()) -- §2 LstPeerOfferGates (payload: offer level sent so far) - , stPeerNotifyQueue :: Map Peer (Seq Notification, Int) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) - , stWanted :: EbHashMap WantState () -- §2 LstWanted - , stVolatileBody :: EbHashMap () () -- §2 LstVolatileBody - , stVolatileClosure :: EbHashMap () () -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) - , stCertified :: Map Election (HeaderHash, EbHash) -- §2 LstCertified - , stPeerInflight :: Map Peer (Seq Req) -- §2 LstPeerInflight - , stPeerPresent :: Map Peer PeerInfo -- §2 LstPeerPresent + { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements + , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements + , stPeerOfferings :: !(Peer :-> (Maybe LeiosNotifySide, Any) :& Maybe ChainSyncSide) -- §2 LstPeerOfferings + , stPeerOfferGates :: !(Peer :-> Maybe OfferLevel :& ()) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) + , stWanted :: !(WantState :& ()) -- §2 LstWanted + , stVolatileBody :: !(() :& ()) -- §2 LstVolatileBody + , stVolatileClosure :: !(() :& ()) -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified + , stPeerInflight :: !(Peer :-> (Seq Req)) -- §2 LstPeerInflight + , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent } deriving (Eq, Show) @@ -185,6 +197,7 @@ data Env = Env , envRequestTimeout :: Word64 -- §2 requestTimeout , envNotifyMaxCapacity :: Int -- §2 notifyMaxCapacity , envNotifyStaleHorizon :: Word64 -- §2 notifyStaleHorizon (slots; ≈ 10 min) + , envOfferDedupTtl :: Word64 -- §2 offer-dedup TTL (wallclock; RedundantOffer epoch, < immutability) , envImmutableTip :: Slot -- ChainDB-owned, harness-updated } deriving (Eq, Show) @@ -220,8 +233,8 @@ data WireMsg -- §2 Wire messages = MsgLeiosNotificationRequestNext | MsgLeiosBlockAnnouncement RbHeader | MsgLeiosBlockEquivocationProof (Maybe RbHeader) RbHeader - | MsgLeiosBlockOffer EbHash - | MsgLeiosBlockTxsOffer EbHash + | MsgLeiosBlockOffer Slot EbHash + | MsgLeiosBlockTxsOffer Slot EbHash | MsgLeiosBlockRequest EbHash | MsgLeiosBlock EbHash Body | MsgLeiosBlockTxsRequest EbHash (NonEmpty TxHash) @@ -342,11 +355,6 @@ electionsFirstAnnouncing st peer eh = | (el, seen) <- Map.toList (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st))) , annEbHashOf (seenFirst seen) == Just eh ] -youngestAnnouncedSlot :: St -> Peer -> EbHash -> Maybe Slot -- BEH-NotifyServe staleness -youngestAnnouncedSlot st peer eh = case map electionSlot (electionsFirstAnnouncing st peer eh) of - [] -> Nothing - ss -> Just (maximum ss) - offerersBody :: St -> EbHash -> Set Peer -- §2 offerersBody · BEH-BodyFetch offerersBody st eh = offerersAtLeast st eh OfferBody @@ -361,10 +369,8 @@ offerersAtLeast st eh need = Set.fromList effectiveOffer :: EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide) -> EbHash -> Maybe OfferLevel -- §2 LstPeerOfferings effective offer effectiveOffer m eh = case EM.lookupEb eh m of - Just (EM.RefCounts a _ (notify, Any chain)) | a > 0 -> max (unwrap <$> notify) (if chain then Just OfferBodyAndClosure else Nothing) + Just (EM.RefCounts a _ (notify, Any chain)) | a > 0 -> max (offerLevel <$> notify) (if chain then Just OfferBodyAndClosure else Nothing) _ -> Nothing - where - unwrap (LeiosNotifySide lvl) = lvl offeredWanted :: St -> Peer -> [EbHash] -- NEEDS-TO-BE-INCREMENTAL: per-peer offered∩wanted set offeredWanted st peer = @@ -483,8 +489,8 @@ stepWired ifs env now peer msg st MsgLeiosNotificationRequestNext -> hRequestNext env peer st MsgLeiosBlockAnnouncement h -> hAnnouncement ifs env now peer h st MsgLeiosBlockEquivocationProof m1 h2 -> hEquivProof env peer m1 h2 st - MsgLeiosBlockOffer eh -> hOffer env now peer eh (LeiosNotifySide OfferBody) st - MsgLeiosBlockTxsOffer eh -> hOffer env now peer eh (LeiosNotifySide OfferBodyAndClosure) st + MsgLeiosBlockOffer sl eh -> hOffer env now peer sl eh OfferBody st + MsgLeiosBlockTxsOffer sl eh -> hOffer env now peer sl eh OfferBodyAndClosure st MsgLeiosBlockRequest eh -> hServeBody ifs env now peer eh st MsgLeiosBlock eh body -> hBlock ifs env now peer eh body st MsgLeiosBlockTxsRequest eh txs -> hServeTxs ifs env now peer eh txs st @@ -552,8 +558,8 @@ ensureWantedBodyAnn st el h = case rbAnnounce h of Just a -> wantBody el (annEbHash a) (annBodySize a) (annClosureSize a) st Nothing -> st -hOffer :: Monad m => Env -> Time -> Peer -> EbHash -> LeiosNotifySide -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer -hOffer env now peer eh lvl st = case electionsFirstAnnouncing st peer eh of +hOffer :: Monad m => Env -> Time -> Peer -> Slot -> EbHash -> OfferLevel -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer +hOffer env now peer sl eh lvl st = case filter ((== sl) . electionSlot) (electionsFirstAnnouncing st peer eh) of [] -> pure (st, [Disconnect peer UnannouncedOffer]) els -> case notifyOf (raiseOffer els st) of Nothing -> pure (st, [Disconnect peer RedundantOffer]) @@ -562,8 +568,11 @@ hOffer env now peer eh lvl st = case electionsFirstAnnouncing st peer eh of raiseOffer els0 s = foldl' (\acc el -> anchorOffer peer el eh acc) s els0 notifyOf s = let perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings s)) - bump (notify, chain) | notify >= Just lvl = Nothing - | otherwise = Just (notify <> Just lvl, chain) + bump (Just (LeiosNotifySide cl ct), chain) + | lvl > cl = Just (Just (LeiosNotifySide lvl now), chain) + | staleOffer env now ct = Just (Just (LeiosNotifySide lvl now), chain) + | otherwise = Nothing + bump (Nothing, chain) = Just (Just (LeiosNotifySide lvl now), chain) in (\m -> s { stPeerOfferings = Map.insert peer m (stPeerOfferings s) }) <$> EM.updateEb eh bump perPeer hRollForward :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> Maybe AnnouncementTriple -> St -> m (St, [Effect]) -- BEH-Offers / BEH-Wanting · §3 LevRollForward @@ -636,19 +645,22 @@ enqueueToAll n st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer n s offerable :: Peer -> EbHash -> OfferLevel -> St -> Bool -- §2 LstPeerOfferGates: announced, and not yet offered at this level offerable peer eh lvl st = case EM.lookupEb eh (fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st))) of - Just (EM.RefCounts _ _ sent) -> sent < Just (LeiosNotifySide lvl) + Just (EM.RefCounts _ _ sent) -> sent < Just lvl Nothing -> False -notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot (youngest, for a multi-election EbHash offer) +notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) notifyMsgSlot _ _ (MsgLeiosBlockEquivocationProof _ h2) = Just (electionSlot (rbElection h2)) -notifyMsgSlot st peer (MsgLeiosBlockOffer eh) = youngestAnnouncedSlot st peer eh -notifyMsgSlot st peer (MsgLeiosBlockTxsOffer eh) = youngestAnnouncedSlot st peer eh +notifyMsgSlot _ _ (MsgLeiosBlockOffer sl _) = Just sl +notifyMsgSlot _ _ (MsgLeiosBlockTxsOffer sl _) = Just sl notifyMsgSlot _ _ _ = Nothing notifyStale :: Env -> Slot -> Bool -- BEH-NotifyServe staleness: slot-difference (as a duration) exceeds notifyStaleHorizon notifyStale env (Slot s) = case envImmutableTip env of Slot tip -> tip > s + envNotifyStaleHorizon env +staleOffer :: Env -> Time -> Time -> Bool -- §3 RedundantOffer TTL: the peer's prior offer is older than the dedup epoch +staleOffer env (Time n) (Time t) = n >= t + envOfferDedupTtl env + sendNotification :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe sendNotification peer n st = case n of NotifyAnnouncement h -> @@ -656,8 +668,19 @@ sendNotification peer n st = case n of eh = maybe (EbHash 0) annEbHash (rbAnnounce h) in (openGate peer el eh st, [Send peer (MsgLeiosBlockAnnouncement h)]) NotifyEquivProof m1 h2 -> (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) - NotifyBlockOffer eh -> (bumpGate peer eh OfferBody st, [Send peer (MsgLeiosBlockOffer eh)]) - NotifyBlockTxsOffer eh -> (bumpGate peer eh OfferBodyAndClosure st, [Send peer (MsgLeiosBlockTxsOffer eh)]) + NotifyBlockOffer eh -> case gateSlot peer eh st of + Just sl -> (bumpGate peer eh OfferBody st, [Send peer (MsgLeiosBlockOffer sl eh)]) + Nothing -> (st, []) + NotifyBlockTxsOffer eh -> case gateSlot peer eh st of + Just sl -> (bumpGate peer eh OfferBodyAndClosure st, [Send peer (MsgLeiosBlockTxsOffer sl eh)]) + Nothing -> (st, []) + +gateSlot :: Peer -> EbHash -> St -> Maybe Slot -- §2 LstPeerOfferGates: a slot we announced eh to peer under · NEEDS-TO-BE-INCREMENTAL +gateSlot peer eh st = + let EM.EbHashMap _ els = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) + in case [ electionSlot el | (el, EM.Refs _ act _) <- Map.toList els, act == eh ] of + (s : _) -> Just s + [] -> Nothing openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates: announcement sent (no offer yet) openGate peer el eh st = @@ -665,7 +688,7 @@ openGate peer el eh st = where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) bumpGate :: Peer -> EbHash -> OfferLevel -> St -> St -- §2 LstPeerOfferGates: record the offer level sent -bumpGate peer eh lvl st = case EM.updateEb eh (\sent -> Just (sent <> Just (LeiosNotifySide lvl))) perPeer of +bumpGate peer eh lvl st = case EM.updateEb eh (\sent -> Just (sent <> Just lvl)) perPeer of Just m' -> st { stPeerOfferGates = Map.insert peer m' (stPeerOfferGates st) } Nothing -> st where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 18829c3646..500a5e9b04 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -19,7 +19,7 @@ main :: IO () main = defaultMain tests env :: Env -env = Env 5 2 1000000 65536 30 300 600 (Slot 0) +env = Env 5 2 1000000 65536 30 300 600 21600 (Slot 0) el100 :: Election el100 = Election (Slot 5) (PoolId 1) @@ -42,10 +42,10 @@ ann :: Peer -> RbHeader -> Stimulus ann p h = LevWiredMsg p (MsgLeiosBlockAnnouncement h) offer :: Peer -> EbHash -> Stimulus -offer p eh = LevWiredMsg p (MsgLeiosBlockOffer eh) +offer p eh = LevWiredMsg p (MsgLeiosBlockOffer (electionSlot el100) eh) txsOffer :: Peer -> EbHash -> Stimulus -txsOffer p eh = LevWiredMsg p (MsgLeiosBlockTxsOffer eh) +txsOffer p eh = LevWiredMsg p (MsgLeiosBlockTxsOffer (electionSlot el100) eh) runWith :: Ifaces Identity -> [Stimulus] -> (St, [Effect]) runWith ifs = foldl' go (emptySt, []) From 0267dcacb7340904e4746c7594e18f0f1035c741 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 04:59:38 -0400 Subject: [PATCH 07/16] WIP add SPEC-DRIFT.md as an intermediate TODO --- .../Test/Leios/RefModel/SPEC-DRIFT.md | 142 ++++++++++++++++++ 1 file changed, 142 insertions(+) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md new file mode 100644 index 0000000000..5206fb78d6 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md @@ -0,0 +1,142 @@ +# Spec.md drift — RefModel.hs is ahead + +Things to reflect back into `Spec.md` (it's at the §1–§8 prose baseline; RefModel.hs has moved +substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — this is the to-do list. + +## Design recommendation to the community + the dedup snag (decided: keep + TTL now, recommend abandoning) + +- [ ] **Recommend abandoning cross-election EB dedup.** `Msg*Offer` should carry the **announcement + triple `(Slot, PoolId, EbHash)`** (i.e. election + EbHash), not just `EbHash`. The CIP's offer + already carries `(Slot, EbHash)`, and the model now provides + confirms that `Slot` (see §2/§3 + Messages) — so only `PoolId` is missing from the full triple. We keep the `EbHash`-only hard-dedup + *for now* (it's a protocol-shape question, not ours to settle in isolation), but the lean is to drop + it. Election-keyed offers make dedup per-election, GC'd by our + own tip, with **no cross-node coupling**; the cost is the rare same-content-two-elections + double-fetch/-offer, which §5 already deemed acceptable and which `stVolatileBody` best-effort + re-fetch avoidance mostly recovers. +- [ ] **Why `EbHash`-only is a snag** (document as the motivation): with `EbHash`-only offers, + `RedundantOffer` correctness becomes a **cross-node GC-epoch invariant**. An honest peer that GC'd + X's old election and re-offers X under a *new* election is wrongly `RedundantOffer`-disconnected + whenever our immutable tip lags its GC; symmetrically the downstream gate would have to be retained + for the **network-max GC window W (≈36 h)** rather than our own tip (≈12 h immutability), in both + directions, decoupled from our tip. +- [ ] **Wallclock TTL that keeps the kept-dedup correct (IMPLEMENTED in RefModel.hs).** `RedundantOffer` + fires only when a non-level-raising offer arrives **within `envOfferDedupTtl` (~6 h)** of the peer's + prior offer of that `EbHash`; a staler one is treated as a fresh epoch and accepted. Robust because a + *legit* re-offer can't happen until the peer itself GC'd (its tip moved ~an immutability-window, + ≥~12 h at real time), so the TTL only has to sit anywhere between spam cadence and immutability — + every node picks its own, no W agreement. The only sub-TTL "legit" re-offerer is a node replaying + faster than real time (syncing), which we don't want as upstream anyway. Lives on the *received*-offer + state only (`stPeerOfferings`, via the `Time` now carried in `LeiosNotifySide`); slot-GC still bounds + memory, the TTL only governs the disconnect. New `Env` param **`envOfferDedupTtl`**. + +## New abstraction not in Spec at all + +- [ ] **`EbHashMap a b`** (its own module). A bidirectional, reference-counted map: per-EB payload `a` + keyed by `EbHash`, refcounted by per-`Election` references (`b` the per-election payload). Each + election holds an *active* and optional *inactive* (superseded) EbHash ref; the EbHash entry's + refcount = #elections naming it; GC by slot-major range-delete on the election side cascading to + drop EbHash entries at refcount 0. `RefCounts` now splits **active vs inactive** counts (so + "actively wanted/offered" is `active > 0`). `supersede` = cert switches an election's active EB. + Spec §2 frames `LstWanted`/`LstPeerOfferings`/`LstPeerOfferGates` as plain `Election ↦ …` maps with + the EbHash↦… reverse indexes "Derived (NOT stored)"; RefModel bakes that reverse index into + EbHashMap (a maintained bidirectional index). The "derived/deferred" framing for + `electionOf`/`offerersBody`/`offerersClosure` needs revisiting. + +## §2 State + +- [ ] **`LstWanted`** is now keyed by `EbHash` (an `EbHashMap WantState ()`), not `Election ↦ WantState`. + `WantState` **dropped its embedded `ebHash`** (`AwaitingBody bs cs | AwaitingTxs (These …)`). + Completion is **per-EbHash**, fanning out to every naming election (`electionsNaming`); a shared + EbHash keeps its existing fetch progress (`Semigroup WantState` = keep-left). +- [ ] **`LstPeerOfferings`** is now `Peer ↦ EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide)`, + not `Peer ↦ Election ↦ These CertSide OfferSide`. + - `OfferSide` → **`OfferLevel`** (`OfferBody | OfferBodyAndClosure`). The per-EB payload's first + component is `Maybe LeiosNotifySide`, where **`LeiosNotifySide = LeiosNotifySide OfferLevel Time`** + carries the offer level *and* when it was last (re)offered (the `RedundantOffer` TTL clock); + `offerLevel` projects the level. (`OfferLevel` has a `max` `Semigroup`.) + - `CertSide` → **`ChainSyncSide HeaderHash`** (per-election payload, `Maybe`; **dropped the EbHash** — + the EbHash is the Refs active ref now). The cert no longer touches the LeiosNotify level. + - per-EB **`Any`** flag = "this EB was ChainSync-offered (cert via LevRollForward)"; kept distinct + from the LeiosNotify level so `RedundantOffer` only consults the latter. + - **`effectiveOffer`** = LeiosNotify level ⊔ (`Any` ⇒ body+closure), per-EB, no election scan. +- [ ] **`LstPeerOfferGates`** is now `Peer ↦ EbHashMap (Maybe OfferLevel) ()` — payload = the offer + **level already sent** to that peer (bare `OfferLevel`, no timestamp — downstream is tip-GC), not + `Election ↦ EbHash`. It is now a pure **dequeue-time** concern (was "open on announcement send"): + `openGate` records announced (`Nothing`), `bumpGate` records the sent level; serves both causality + (announced) and dedup (sent-level) — see §3. +- [ ] **`LstPeerNotifyQueue`** is now a **FIFO `Seq`** (`Peer ↦ (Seq Notification, Int)`), not a + `notifyPriority`-ordered `Set`. Overflow = **tail-drop** (drop the newest message being added). + Remove `notifyPriority`, the whole **Helper-functions §2 entry and its two-slot-ordered-queues + Aside** (moot), and the `Set`/priority eviction wording. +- [ ] **NEW: `LstVolatileBody` / `LstVolatileClosure`** (`EbHashMap () ()` each) — the in-memory sets of + EBs whose body / full closure we hold. INVARIANT closure ⊆ body. Maintained: body added on + `LevDiskDone` body-write, closure added on completion; **trimmed by Promotion** (`pruneBelow` at + `LevImmTipAdvanced`). `LstVolatileClosure` is ChainSel's queryable "available complete closures" set + (no disk read); `NotifyVotingAndChainSel` is the "set grew" signal. (LeiosDb may ultimately own it; + Spec should still specify the maintenance.) +- [ ] **`Req` dropped its `Election`** (`ReqBody EbHash bs cs | ReqJob EbHash JobId Job`); likewise + `DiskWrite` (`WriteBody Body | WriteClosure EbHash [Tx]`). Spec §2 carries `el` in both. +- [ ] **`Notification`** offer ctors dropped the election (`NotifyBlockOffer EbHash` / + `NotifyBlockTxsOffer EbHash`). +- [ ] **NEW offence `RedundantOffer`** — an inbound offer that raises no LeiosNotify level disconnects + (within the TTL; see §3). +- [ ] **NEW parameter `envOfferDedupTtl`** (~6 h, wallclock; the `RedundantOffer` dedup epoch, kept well + below the immutability window) — §2 Parameters. + +## §2 Messages / stimuli + +- [ ] **`MsgLeiosBlockOffer(Slot, ebHash)` / `MsgLeiosBlockTxsOffer(Slot, ebHash)`** carry `(Slot, EbHash)` + (matching the CIP), no longer the full election (Spec §2 + the §5 dedup TODO say they carry an + election). The receiver resolves EbHash → election(s) via its own first-announcement index + (`electionsFirstAnnouncing`, the old `electionOf`). +- [ ] **The model both provides and confirms the offer's `Slot`.** *Provide* (send): `sendNotification` + derives the slot per-peer from `gateSlot` — an election we actually announced this EbHash to *that* + peer under (scanned from `LstPeerOfferGates`) — so it is always confirmable by the recipient. + *Confirm* (receive): `hOffer` filters the peer's first-announcements of the EbHash to those at the + claimed `Slot`; an empty result ⇒ `UnannouncedOffer`. The carried `Slot` would also let dedup be + keyed by `(Slot, EbHash)` (obviating the wallclock TTL), but we deliberately kept dedup per-`EbHash` + + TTL for now — only `(a)` of the CIP-alignment was adopted. `notifyMsgSlot` now reads the stale + horizon's slot straight off the offer message (the old `youngestAnnouncedSlot` is gone). + +## §3 Rules + +- [ ] **`LevBlockOffer`/`LevBlockTxsOffer`**: offer carries `(Slot, ebHash)`; resolve naming elections + filtered to the claimed `Slot` (non-empty ⇒ else `UnannouncedOffer`), raise the per-EB LeiosNotify + level once. A non-raising offer ⇒ `RedundantOffer` disconnect **only if** the peer's prior offer of + that EbHash was within `envOfferDedupTtl` (the wallclock TTL); a staler one is treated as a fresh + epoch and accepted. +- [ ] **`LevNotifyDequeue`**: FIFO pop-front. Discard (no credit consumed) if stale (announce/equiv via + header slot) **or** if it's an offer that fails the gate (`offerable`: unannounced ⇒ causality, or + sent-level already ≥ this level ⇒ dedup). Else send; announcement → `openGate`, offer → `bumpGate`. +- [ ] **Offer emission is unconditional + gate-at-dequeue**: `LevDiskDone`/completion enqueue offers to + **all** present peers (`enqueueToAll`), not "to gated peers"; the gate filters at dequeue. The + `Set`'s silent dedup is replaced by the gate sent-level. +- [ ] **`LevBlockAnnouncement` / centralAnnounce** additions: `anchorVolatile` (a fresh announcement + extends a held EB's elections in `LstVolatile*`); fetch **dedup** (skip wanting if eh already in + `LstVolatileClosure`); **`enqueueHeldOffers`** (when relaying an announcement for an EB we already + hold, also offer it — the late-downstream-peer fix). +- [ ] **`LevDiskDone`**: body-write adds to `LstVolatileBody` (+ body offers); completion adds to + `LstVolatileClosure` (+ closure offers + `NotifyVotingAndChainSel` per naming election). Completion + is per-EbHash (`completeEb`), not per-election. +- [ ] **`LevRollForward` cert bit / `recordChainSyncSide`**: `supersede` sets the per-EB `Any` ChainSync + flag (leaving the LeiosNotify level untouched) + per-election `Just (ChainSyncSide hh)`; guarded + against a repeat cert. Spec records `These (Cert …) BodyAndClosure`. +- [ ] **`LevCertValidated`**: uses `supersede` into the `EbHashMap` (and `deleteElection` when already + complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. + +## §4 Properties + +- [ ] "Offers are announced or certified" now keys off the EbHashMap supersede state + (`NoInactiveRefYet` ⇒ must be first-announced) rather than `These`/`CertSide`. +- [ ] "Announce-before-offer" is now enforced at **dequeue** (`offerable`'s gate check), and the gate also + gives **offer dedup** (no duplicate downstream offer) and **inbound `RedundantOffer`**. +- [ ] New invariants worth stating: `LstVolatileClosure ⊆ LstVolatileBody`; gate sent-level is monotone; + `RefCounts` active/inactive tally matches the election refs (already an EbHashMap test invariant). + +## §5 Roadmap — items now DONE (move out of roadmap) + +- [ ] **"Dedup offers/fetches across elections that share an EbHash"** is **done**: offers are + EbHash-only and deduped hard via the EbHashMap; the suggested "in-memory set of currently-persisted + bodies, akin to `LstTxCacheIndex`" is exactly **`LstVolatileBody`**. The bullet's premise (offers + carry the election) is now obsolete. From 81340227e74290fbc98ec046bfba56d2b517d70a Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 06:21:06 -0400 Subject: [PATCH 08/16] WIP simplify EbHashMap; strengthen CertConflict check --- .../Test/Leios/RefModel/EbHashMap.hs | 68 +++++++------- .../Test/Leios/RefModel/RefModel.hs | 90 ++++++++++-------- .../Test/Leios/RefModel/SPEC-DRIFT.md | 93 ++++++++++++------- .../Test/Leios/RefModel/test/RefModelTest.hs | 70 +++++++------- 4 files changed, 185 insertions(+), 136 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs index 2e6101377f..778bc86de9 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/EbHashMap.hs @@ -54,12 +54,12 @@ data Election = Election Slot PoolId -- election = (slot, pool) electionSlot :: Election -> Slot electionSlot (Election s _) = s --- | An election's references: the inactive (superseded) reference, the active --- reference, and a per-election payload. +-- | An election's references: the inactive (superseded) reference and the +-- active reference. -- -- INVARIANT: the active reference is never equal to the inactive one. -data Refs b = Refs !InactiveRef !EbHash !b - deriving (Eq, Functor, Show) +data Refs = Refs !InactiveRef !EbHash + deriving (Eq, Show) data InactiveRef = NoInactiveRefYet @@ -68,8 +68,8 @@ data InactiveRef = | InactiveRef !EbHash deriving (Eq, Show) -activeRef :: Refs b -> EbHash -activeRef (Refs _ act _) = act +activeRef :: Refs -> EbHash +activeRef (Refs _ act) = act -- | An EB's active and inactive reference counts (how many elections name it as -- their active EB, and how many as their inactive/superseded EB) and a per-EB @@ -86,17 +86,17 @@ refCount (RefCounts a i _) = a + i ----- -- | A bidirectional, reference-counted map between elections and the EBs they --- name: @a@ is the per-EB payload, @b@ the per-election payload. +-- name: @a@ is the per-EB payload; the election side carries no payload. -- -- INVARIANT: the EB map's keys are exactly the EBs named (active or inactive) by -- some election, and each EB's count equals the number of elections naming it. -data EbHashMap a b = +data EbHashMap a = EbHashMap !(Map EbHash (RefCounts a)) - !(Map Election (Refs b)) + !(Map Election Refs) deriving (Eq, Show) -empty :: EbHashMap a b +empty :: EbHashMap a empty = EbHashMap Map.empty Map.empty incRefActive :: Semigroup a => EbHash -> a -> Map EbHash (RefCounts a) -> Map EbHash (RefCounts a) @@ -131,20 +131,20 @@ decRefInactive = Map.update step | a + i <= 1 = Nothing | otherwise = Just (RefCounts a (i - 1) x) --- | This @b@ value is only the default; update it with 'supersede' -upsert :: Semigroup a => EbHash -> Election -> a -> b -> EbHashMap a b -> EbHashMap a b -upsert eh el a' b (EbHashMap ebs els) = +-- | Add @el@'s active reference to @eh@, combining the per-EB payload via '<>' +upsert :: Semigroup a => EbHash -> Election -> a -> EbHashMap a -> EbHashMap a +upsert eh el a' (EbHashMap ebs els) = case Map.lookup el els of Nothing -> - EbHashMap (incRefActive eh a' ebs) (setEl (Refs NoInactiveRefYet eh b)) - Just (Refs _ act _) + EbHashMap (incRefActive eh a' ebs) (setEl (Refs NoInactiveRefYet eh)) + Just (Refs _ act) | act == eh -> EbHashMap (Map.adjust (fmap (<> a')) eh ebs) els | otherwise -> error "EbHashMap.insert: inserted the wrong EbHash" where setEl r = Map.insert el r els -- | 'Nothing' if the lookup missed or the update returned 'Nothing' -updateEb :: EbHash -> (a -> Maybe a) -> EbHashMap a b -> Maybe (EbHashMap a b) +updateEb :: EbHash -> (a -> Maybe a) -> EbHashMap a -> Maybe (EbHashMap a) updateEb eh f (EbHashMap ebs els) = (\x -> EbHashMap x els) <$> Map.alterF @@ -158,50 +158,50 @@ updateEb eh f (EbHashMap ebs els) = ebs -- | This @a@ value is only the default; update it with 'upsert' or 'updateEb' -supersede :: Semigroup a => Election -> EbHash -> a -> b -> EbHashMap a b -> EbHashMap a b -supersede el eh a b (EbHashMap ebs els) = +supersede :: Semigroup a => Election -> EbHash -> a -> EbHashMap a -> EbHashMap a +supersede el eh a (EbHashMap ebs els) = case Map.lookup el els of Nothing -> - EbHashMap (incRefActive eh a ebs) (Map.insert el (Refs NoInactiveRef eh b) els) - Just (Refs NoInactiveRefYet act _) - | act == eh -> EbHashMap (Map.adjust (fmap (<> a)) eh ebs) (Map.insert el (Refs NoInactiveRef act b) els) - | otherwise -> EbHashMap (deactivateRef act eh a ebs) (Map.insert el (Refs (InactiveRef act) eh b) els) - Just (Refs NoInactiveRef _ _) -> error "EbHashMap.supersede: election already superseded" - Just (Refs InactiveRef{} _ _) -> error "EbHashMap.supersede: election already superseded" - -lookupEb :: EbHash -> EbHashMap a b -> Maybe (RefCounts a) + EbHashMap (incRefActive eh a ebs) (Map.insert el (Refs NoInactiveRef eh) els) + Just (Refs NoInactiveRefYet act) + | act == eh -> EbHashMap (Map.adjust (fmap (<> a)) eh ebs) (Map.insert el (Refs NoInactiveRef act) els) + | otherwise -> EbHashMap (deactivateRef act eh a ebs) (Map.insert el (Refs (InactiveRef act) eh) els) + Just (Refs NoInactiveRef _) -> error "EbHashMap.supersede: election already superseded" + Just (Refs InactiveRef{} _) -> error "EbHashMap.supersede: election already superseded" + +lookupEb :: EbHash -> EbHashMap a -> Maybe (RefCounts a) lookupEb eh (EbHashMap ebs _) = Map.lookup eh ebs -lookupElection :: Election -> EbHashMap a b -> Maybe (Refs b) +lookupElection :: Election -> EbHashMap a -> Maybe Refs lookupElection el (EbHashMap _ els) = Map.lookup el els -deleteElection :: Election -> EbHashMap a b -> EbHashMap a b +deleteElection :: Election -> EbHashMap a -> EbHashMap a deleteElection el m@(EbHashMap ebs els) = case Map.lookup el els of Nothing -> m - Just (Refs inact act _) -> EbHashMap (dropRefs ebs inact act) (Map.delete el els) + Just (Refs inact act) -> EbHashMap (dropRefs ebs inact act) (Map.delete el els) -pruneElections :: (Election -> Bool) -> EbHashMap a b -> EbHashMap a b +pruneElections :: (Election -> Bool) -> EbHashMap a -> EbHashMap a pruneElections p (EbHashMap ebs els) = EbHashMap (foldl' step ebs (Map.elems dropped)) kept where (dropped, kept) = Map.partitionWithKey (\el _ -> p el) els - step acc (Refs inact act _) = dropRefs acc inact act + step acc (Refs inact act) = dropRefs acc inact act dropRefs :: Map EbHash (RefCounts a) -> InactiveRef -> EbHash -> Map EbHash (RefCounts a) dropRefs ebs inact act = case inact of InactiveRef old -> decRefInactive old (decRefActive act ebs); _ -> decRefActive act ebs -invariant :: EbHashMap a b -> Bool +invariant :: EbHashMap a -> Bool invariant (EbHashMap ebs els) = all neverEqual (Map.elems els) && Map.keys tally == Map.keys ebs && and (Map.intersectionWith (\(a, i) (RefCounts a' i' _) -> a == a' && i == i') tally ebs) && all (\(RefCounts a i _) -> 0 < a + i) (Map.elems ebs) where - neverEqual (Refs inact act _) = case inact of InactiveRef eh -> eh /= act; _ -> True + neverEqual (Refs inact act) = case inact of InactiveRef eh -> eh /= act; _ -> True tally = foldl' count Map.empty (Map.elems els) - count m (Refs inact act _) = + count m (Refs inact act) = let m1 = Map.insertWith addPair act ((1, 0) :: (Word16, Word16)) m in case inact of InactiveRef old -> Map.insertWith addPair old (0, 1) m1; _ -> m1 addPair (a1, i1) (a2, i2) = (a1 + a2, i1 + i2) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index cfddf66c73..96c0a2cf45 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -168,18 +168,18 @@ data Notification -- §2 LstPeerNotifyQueue infixr 1 :-> type k :-> v = Map k v -infix 9 :& -type a :& b = EbHashMap a b +data PeerOfferings = PeerOfferings !(EbHashMap (Maybe LeiosNotifySide, Any)) !(Election :-> ChainSyncSide) -- §2 LstPeerOfferings (offer levels; per-election ChainSync header hashes) + deriving (Eq, Show) data St = St { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: !(Peer :-> (Maybe LeiosNotifySide, Any) :& Maybe ChainSyncSide) -- §2 LstPeerOfferings - , stPeerOfferGates :: !(Peer :-> Maybe OfferLevel :& ()) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerOfferings :: !(Peer :-> PeerOfferings) -- §2 LstPeerOfferings + , stPeerOfferGates :: !(Peer :-> EbHashMap (Maybe OfferLevel)) -- §2 LstPeerOfferGates (payload: offer level sent so far) , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) - , stWanted :: !(WantState :& ()) -- §2 LstWanted - , stVolatileBody :: !(() :& ()) -- §2 LstVolatileBody - , stVolatileClosure :: !(() :& ()) -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stWanted :: !(EbHashMap WantState) -- §2 LstWanted + , stVolatileBody :: !(EbHashMap ()) -- §2 LstVolatileBody + , stVolatileClosure :: !(EbHashMap ()) -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified , stPeerInflight :: !(Peer :-> (Seq Req)) -- §2 LstPeerInflight , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent @@ -189,6 +189,21 @@ data St = St emptySt :: St -- BEH-Startup emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty EM.empty EM.empty EM.empty Map.empty Map.empty Map.empty +emptyPeerOfferings :: PeerOfferings -- §2 LstPeerOfferings +emptyPeerOfferings = PeerOfferings EM.empty Map.empty + +peerOfferings :: Peer -> St -> PeerOfferings -- §2 LstPeerOfferings +peerOfferings peer st = fromMaybe emptyPeerOfferings (Map.lookup peer (stPeerOfferings st)) + +peerOfferingsEbm :: Peer -> St -> EbHashMap (Maybe LeiosNotifySide, Any) -- §2 LstPeerOfferings +peerOfferingsEbm peer st = let PeerOfferings m _ = peerOfferings peer st in m + +peerChainSync :: Peer -> St -> Election :-> ChainSyncSide -- §2 LstPeerOfferings +peerChainSync peer st = let PeerOfferings _ c = peerOfferings peer st in c + +modifyPeerOfferings :: Peer -> (PeerOfferings -> PeerOfferings) -> St -> St -- §2 LstPeerOfferings +modifyPeerOfferings peer f st = st { stPeerOfferings = Map.insert peer (f (peerOfferings peer st)) (stPeerOfferings st) } + data Env = Env { envStakeMaxActiveEbs :: Int -- §2 stakeMaxActiveEbs , envPeerSharingMaxActiveEbs :: Int -- §2 peerSharingMaxActiveEbs @@ -274,7 +289,7 @@ data Offence -- §3 disconnect reasons (c | BogusEquivocationProof -- did not prove a genuine equivocation | UnannouncedOffer -- offered an EB the peer never first-announced | RedundantOffer -- an offer that raised no EB's LeiosNotify level - | CertConflict -- cert for a HeaderHash conflicting with our validated cert + | CertConflict -- certified HeaderHash conflicting with a known cert (ours, or the peer's own prior claim) for the election | BodyMismatch -- body disagrees with the request (hash / size / closure size) | TxsMismatch -- closure txs disagree with the requested job (content or order) | UnsolicitedResponse -- a response matching no front in-flight request @@ -341,7 +356,7 @@ wantedEbs st = let EM.EbHashMap ebs _ = stWanted st in Map.keys (Map.filter (\(E electionsNaming :: EbHash -> St -> [Election] -- §2 LstWanted reverse EbHash↦Elections · NEEDS-TO-BE-INCREMENTAL: maintained reverse index electionsNaming eh st = let EM.EbHashMap _ els = stWanted st - in [ el | (el, EM.Refs _ act _) <- Map.toList els, act == eh ] + in [ el | (el, EM.Refs _ act) <- Map.toList els, act == eh ] firstAnnouncedEb :: St -> Peer -> Election -> Maybe EbHash -- §2 LstPeerFirstAnnouncements firstAnnouncedEb st peer el = do @@ -364,10 +379,10 @@ offerersClosure st eh = offerersAtLeast st eh OfferBodyAndClosure offerersAtLeast :: St -> EbHash -> OfferLevel -> Set Peer -- NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦offering-peers index offerersAtLeast st eh need = Set.fromList [ peer - | (peer, m) <- Map.toList (stPeerOfferings st) + | (peer, PeerOfferings m _) <- Map.toList (stPeerOfferings st) , effectiveOffer m eh >= Just need ] -effectiveOffer :: EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide) -> EbHash -> Maybe OfferLevel -- §2 LstPeerOfferings effective offer +effectiveOffer :: EbHashMap (Maybe LeiosNotifySide, Any) -> EbHash -> Maybe OfferLevel -- §2 LstPeerOfferings effective offer effectiveOffer m eh = case EM.lookupEb eh m of Just (EM.RefCounts a _ (notify, Any chain)) | a > 0 -> max (offerLevel <$> notify) (if chain then Just OfferBodyAndClosure else Nothing) _ -> Nothing @@ -567,13 +582,13 @@ hOffer env now peer sl eh lvl st = case filter ((== sl) . electionSlot) (electio where raiseOffer els0 s = foldl' (\acc el -> anchorOffer peer el eh acc) s els0 notifyOf s = - let perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings s)) + let perPeer = peerOfferingsEbm peer s bump (Just (LeiosNotifySide cl ct), chain) | lvl > cl = Just (Just (LeiosNotifySide lvl now), chain) | staleOffer env now ct = Just (Just (LeiosNotifySide lvl now), chain) | otherwise = Nothing bump (Nothing, chain) = Just (Just (LeiosNotifySide lvl now), chain) - in (\m -> s { stPeerOfferings = Map.insert peer m (stPeerOfferings s) }) <$> EM.updateEb eh bump perPeer + in (\m -> modifyPeerOfferings peer (\(PeerOfferings _ c) -> PeerOfferings m c) s) <$> EM.updateEb eh bump perPeer hRollForward :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> Maybe AnnouncementTriple -> St -> m (St, [Effect]) -- BEH-Offers / BEH-Wanting · §3 LevRollForward hRollForward ifs env now peer h pe st = do @@ -588,21 +603,22 @@ hRollForward ifs env now peer h pe st = do rollForwardCert :: Peer -> AnnouncementTriple -> St -> (St, [Effect]) -- §3 LevRollForward cert bit rollForwardCert peer at st = let el = atElection at - conflict = case Map.lookup el (stCertified st) of - Just (hh, _) -> hh /= atHeaderHash at - Nothing -> False - in if conflict + ourConflict = case Map.lookup el (stCertified st) of + Just (hh, _) -> hh /= atHeaderHash at + Nothing -> False + peerConflict = case Map.lookup el (peerChainSync peer st) of + Just (ChainSyncSide hh) -> hh /= atHeaderHash at + Nothing -> False + in if ourConflict || peerConflict then (st, [Disconnect peer CertConflict]) else (recordChainSyncSide peer el (atHeaderHash at) (atEbHash at) st, []) recordChainSyncSide :: Peer -> Election -> HeaderHash -> EbHash -> St -> St -- §3 LevRollForward cert bit recordChainSyncSide peer el hh eh st = - case EM.lookupElection el perPeer of - Just (EM.Refs EM.NoInactiveRef _ _) -> st - Just (EM.Refs (EM.InactiveRef _) _ _) -> st - _ -> st { stPeerOfferings = Map.insert peer (EM.supersede el eh (Nothing, Any True) (Just (ChainSyncSide hh)) perPeer) (stPeerOfferings st) } - where - perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)) + case EM.lookupElection el (peerOfferingsEbm peer st) of + Just (EM.Refs EM.NoInactiveRef _) -> st + Just (EM.Refs (EM.InactiveRef _) _) -> st + _ -> modifyPeerOfferings peer (\(PeerOfferings m c) -> PeerOfferings (EM.supersede el eh (Nothing, Any True) m) (Map.insert el (ChainSyncSide hh) c)) st hRequestNext :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotificationRequestNext hRequestNext env peer st = @@ -678,13 +694,13 @@ sendNotification peer n st = case n of gateSlot :: Peer -> EbHash -> St -> Maybe Slot -- §2 LstPeerOfferGates: a slot we announced eh to peer under · NEEDS-TO-BE-INCREMENTAL gateSlot peer eh st = let EM.EbHashMap _ els = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) - in case [ electionSlot el | (el, EM.Refs _ act _) <- Map.toList els, act == eh ] of + in case [ electionSlot el | (el, EM.Refs _ act) <- Map.toList els, act == eh ] of (s : _) -> Just s [] -> Nothing openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates: announcement sent (no offer yet) openGate peer el eh st = - st { stPeerOfferGates = Map.insert peer (EM.upsert eh el Nothing () perPeer) (stPeerOfferGates st) } + st { stPeerOfferGates = Map.insert peer (EM.upsert eh el Nothing perPeer) (stPeerOfferGates st) } where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) bumpGate :: Peer -> EbHash -> OfferLevel -> St -> St -- §2 LstPeerOfferGates: record the offer level sent @@ -761,7 +777,7 @@ hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st = do hPeerAdd :: Monad m => Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd hPeerAdd peer cls st = pure ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) - , stPeerOfferings = Map.insert peer EM.empty (stPeerOfferings st) } + , stPeerOfferings = Map.insert peer emptyPeerOfferings (stPeerOfferings st) } , [] ) hPeerWindDown :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerWindDown @@ -869,10 +885,10 @@ popFront peer st = st { stPeerInflight = Map.adjust dropFront peer (stPeerInflig where dropFront sq = case sq of _ :<| rest -> rest; Empty -> Empty wantBody :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (announcement; keep existing progress if already wanted) -wantBody el eh bs cs st = st { stWanted = EM.upsert eh el (AwaitingBody bs cs) () (stWanted st) } +wantBody el eh bs cs st = st { stWanted = EM.upsert eh el (AwaitingBody bs cs) (stWanted st) } supersedeWant :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (cert validated; once per election) -supersedeWant el eh bs cs st = st { stWanted = EM.supersede el eh (AwaitingBody bs cs) () (stWanted st) } +supersedeWant el eh bs cs st = st { stWanted = EM.supersede el eh (AwaitingBody bs cs) (stWanted st) } updateWant :: EbHash -> (WantState -> Maybe WantState) -> St -> St -- §2 LstWanted (in-place per-EB payload update; no-op if absent) updateWant eh f st = st { stWanted = fromMaybe (stWanted st) (EM.updateEb eh f (stWanted st)) } @@ -902,10 +918,10 @@ enqueueBodyOffers eh = enqueueToAll (NotifyBlockOffer eh) enqueueClosureOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) enqueueClosureOffers eh = enqueueToAll (NotifyBlockTxsOffer eh) -addVolatile :: EbHash -> [Election] -> EbHashMap () () -> EbHashMap () () -- §2 LstVolatileBody/LstVolatileClosure -addVolatile eh els m = foldl' (\acc el -> EM.upsert eh el () () acc) m els +addVolatile :: EbHash -> [Election] -> EbHashMap () -> EbHashMap () -- §2 LstVolatileBody/LstVolatileClosure +addVolatile eh els m = foldl' (\acc el -> EM.upsert eh el () acc) m els -heldIn :: EbHash -> EbHashMap a b -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership +heldIn :: EbHash -> EbHashMap a -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership heldIn eh m = isJust (EM.lookupEb eh m) pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete @@ -916,7 +932,7 @@ pruneBelow s st = st , stVolatileClosure = EM.pruneElections (\el -> electionSlot el < s) (stVolatileClosure st) , stCertified = pruneElectionMap s (stCertified st) , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) - , stPeerOfferings = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferings st) + , stPeerOfferings = Map.map (\(PeerOfferings m c) -> PeerOfferings (EM.pruneElections (\el -> electionSlot el < s) m) (pruneElectionMap s c)) (stPeerOfferings st) , stPeerOfferGates = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferGates st) } @@ -978,15 +994,15 @@ copyAnnIntoOfferings peer el st = case firstAnnouncedEb st peer el of Just eh | offered eh -> anchorOffer peer el eh st _ -> st where - offered eh = isJust (EM.lookupEb eh (fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)))) + offered eh = isJust (EM.lookupEb eh (peerOfferingsEbm peer st)) anchorOffer :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferings anchorOffer peer el eh st = case EM.activeRef <$> EM.lookupElection el perPeer of Just act | act /= eh -> st - _ -> st { stPeerOfferings = Map.insert peer (EM.upsert eh el (Nothing, Any False) Nothing perPeer) (stPeerOfferings st) } + _ -> modifyPeerOfferings peer (\(PeerOfferings m c) -> PeerOfferings (EM.upsert eh el (Nothing, Any False) m) c) st where - perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferings st)) + perPeer = peerOfferingsEbm peer st nullIfaces :: Applicative m => Ifaces m nullIfaces = Ifaces @@ -1015,9 +1031,9 @@ prop_offersAnnouncedOrCertified st = and [ case inact of EM.NoInactiveRefYet -> isJust (firstAnnouncedEb st peer el) _ -> True - | (peer, m) <- Map.toList (stPeerOfferings st) + | (peer, PeerOfferings m _) <- Map.toList (stPeerOfferings st) , let EM.EbHashMap _ els = m - , (el, EM.Refs inact _ _) <- Map.toList els ] + , (el, EM.Refs inact _) <- Map.toList els ] prop_inflightOffered :: St -> Bool -- §4 Client soundness (offer half) prop_inflightOffered st = and diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md index 5206fb78d6..311555b4b8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md @@ -3,37 +3,51 @@ Things to reflect back into `Spec.md` (it's at the §1–§8 prose baseline; RefModel.hs has moved substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — this is the to-do list. -## Design recommendation to the community + the dedup snag (decided: keep + TTL now, recommend abandoning) +## Per-`EbHash` dedup + wallclock TTL — favored; `(Slot, PoolId, EbHash)` triple is the alternative -- [ ] **Recommend abandoning cross-election EB dedup.** `Msg*Offer` should carry the **announcement - triple `(Slot, PoolId, EbHash)`** (i.e. election + EbHash), not just `EbHash`. The CIP's offer - already carries `(Slot, EbHash)`, and the model now provides + confirms that `Slot` (see §2/§3 - Messages) — so only `PoolId` is missing from the full triple. We keep the `EbHash`-only hard-dedup - *for now* (it's a protocol-shape question, not ours to settle in isolation), but the lean is to drop - it. Election-keyed offers make dedup per-election, GC'd by our - own tip, with **no cross-node coupling**; the cost is the rare same-content-two-elections - double-fetch/-offer, which §5 already deemed acceptable and which `stVolatileBody` best-effort - re-fetch avoidance mostly recovers. -- [ ] **Why `EbHash`-only is a snag** (document as the motivation): with `EbHash`-only offers, - `RedundantOffer` correctness becomes a **cross-node GC-epoch invariant**. An honest peer that GC'd - X's old election and re-offers X under a *new* election is wrongly `RedundantOffer`-disconnected - whenever our immutable tip lags its GC; symmetrically the downstream gate would have to be retained - for the **network-max GC window W (≈36 h)** rather than our own tip (≈12 h immutability), in both - directions, decoupled from our tip. -- [ ] **Wallclock TTL that keeps the kept-dedup correct (IMPLEMENTED in RefModel.hs).** `RedundantOffer` - fires only when a non-level-raising offer arrives **within `envOfferDedupTtl` (~6 h)** of the peer's - prior offer of that `EbHash`; a staler one is treated as a fresh epoch and accepted. Robust because a - *legit* re-offer can't happen until the peer itself GC'd (its tip moved ~an immutability-window, - ≥~12 h at real time), so the TTL only has to sit anywhere between spam cadence and immutability — - every node picks its own, no W agreement. The only sub-TTL "legit" re-offerer is a node replaying - faster than real time (syncing), which we don't want as upstream anyway. Lives on the *received*-offer - state only (`stPeerOfferings`, via the `Time` now carried in `LeiosNotifySide`); slot-GC still bounds - memory, the TTL only governs the disconnect. New `Env` param **`envOfferDedupTtl`**. +- [ ] **Favored: keep per-`EbHash` dedup with the wallclock TTL (IMPLEMENTED in RefModel.hs).** An offer is + a per-*content* claim ("I hold the body/closure for this `EbHash`"); the per-election information the + receiver actually acts on (younger elections raise fetch priority; voting needs the election set) + rides on the *announcement* stream, not on offers. So one offer per `EbHash` conveys everything an + offer is for, and a second offer of the same content under a different election adds nothing the + receiver will act on. Per-`EbHash` dedup suppresses that redundant traffic, and makes the frugal + behavior the path of least resistance: an honest sender's natural lifecycle (announce, offer once when + it holds the EB, never re-offer because it never loses-and-reacquires inside the window) is + automatically compliant — no re-offer timer, no per-election offer bookkeeping. +- [ ] **The snag the TTL closes** (document as the TTL's motivation): with `EbHash`-only offers and no TTL, + `RedundantOffer` correctness would be a **cross-node GC-epoch invariant**. An honest peer that GC'd + X's old election and later re-offers X under a *new* election would be wrongly + `RedundantOffer`-disconnected whenever our immutable tip lags its GC; symmetrically the downstream gate + would have to be retained for the **network-max GC window W (≈36 h)** rather than our own tip (≈12 h + immutability), decoupled from our tip in both directions. +- [ ] **How the TTL closes it.** `RedundantOffer` fires only when a non-level-raising offer arrives **within + `envOfferDedupTtl` (~6 h)** of the peer's prior offer of that `EbHash`; a staler one is treated as a + fresh epoch and accepted. Robust because a *legit* re-offer can't happen until the peer itself GC'd + (its tip moved ~an immutability-window, ≥~12 h at real time), so the TTL only has to sit anywhere + between spam cadence and immutability — every node picks its own, no W agreement. The only sub-TTL + "legit" re-offerer is a node replaying faster than real time (syncing), which we don't want as upstream + anyway. The TTL is a little ugly (a wallclock in the dedup) but simple, and its **safe interval is + enormous — not a tuning challenge**. Lives on the *received*-offer state only (`stPeerOfferings`, via + the `Time` in `LeiosNotifySide`); slot-GC still bounds memory, the TTL only governs the disconnect. + New `Env` param **`envOfferDedupTtl`**. The level-raise case (had body, now have closure) is permitted + regardless of the TTL (`lvl > cl`), and works cross-election because the level lives per-content. +- [ ] **Alternative (no longer the lean): the announcement triple `(Slot, PoolId, EbHash)`, dedup keyed by + it** (or, halfway, `(Slot, EbHash)` — the CIP offer + our model already carry and confirm the `Slot`, + so only `PoolId` is missing). It is exact and clockless: distinct elections naming the same content are + distinct dedup keys, GC'd by our own tip with **no cross-node coupling**, so the snag above never + arises. But the exactness is about a distinction the offer layer doesn't need: it **permits** the rare + same-content-multiple-elections case to send one offer per election (redundant traffic the receiver + won't act on) and **decentralizes** the dedup duty onto every sender. Per-`EbHash` and triple keying + behave identically except in that rare multi-election case (an `EbHash` named by >1 election is + basically equivocation/coincidence) — and there, per-`EbHash` suppresses the redundancy while the + triple permits it. Net: the triple trades the TTL's wallclock for permitted redundancy + a sender + burden; given the TTL's safe interval isn't a tuning problem, keep-dedup-with-TTL comes out ahead. ## New abstraction not in Spec at all -- [ ] **`EbHashMap a b`** (its own module). A bidirectional, reference-counted map: per-EB payload `a` - keyed by `EbHash`, refcounted by per-`Election` references (`b` the per-election payload). Each +- [ ] **`EbHashMap a`** (its own module). A bidirectional, reference-counted map: per-EB payload `a` + keyed by `EbHash`, refcounted by per-`Election` references; the **election side carries no payload** + (the `b` parameter was dropped — `Refs = Refs !InactiveRef !EbHash`). Each election holds an *active* and optional *inactive* (superseded) EbHash ref; the EbHash entry's refcount = #elections naming it; GC by slot-major range-delete on the election side cascading to drop EbHash entries at refcount 0. `RefCounts` now splits **active vs inactive** counts (so @@ -45,18 +59,22 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — ## §2 State -- [ ] **`LstWanted`** is now keyed by `EbHash` (an `EbHashMap WantState ()`), not `Election ↦ WantState`. +- [ ] **`LstWanted`** is now keyed by `EbHash` (an `EbHashMap WantState`), not `Election ↦ WantState`. `WantState` **dropped its embedded `ebHash`** (`AwaitingBody bs cs | AwaitingTxs (These …)`). Completion is **per-EbHash**, fanning out to every naming election (`electionsNaming`); a shared EbHash keeps its existing fetch progress (`Semigroup WantState` = keep-left). -- [ ] **`LstPeerOfferings`** is now `Peer ↦ EbHashMap (Maybe LeiosNotifySide, Any) (Maybe ChainSyncSide)`, - not `Peer ↦ Election ↦ These CertSide OfferSide`. +- [ ] **`LstPeerOfferings`** is now `Peer ↦ PeerOfferings`, a product of an + `EbHashMap (Maybe LeiosNotifySide, Any)` (offer levels, keyed by `EbHash`) **and** a separate + `Election ↦ ChainSyncSide` map (per-election ChainSync RB header hashes). Not + `Peer ↦ Election ↦ These CertSide OfferSide`. - `OfferSide` → **`OfferLevel`** (`OfferBody | OfferBodyAndClosure`). The per-EB payload's first component is `Maybe LeiosNotifySide`, where **`LeiosNotifySide = LeiosNotifySide OfferLevel Time`** carries the offer level *and* when it was last (re)offered (the `RedundantOffer` TTL clock); `offerLevel` projects the level. (`OfferLevel` has a `max` `Semigroup`.) - - `CertSide` → **`ChainSyncSide HeaderHash`** (per-election payload, `Maybe`; **dropped the EbHash** — - the EbHash is the Refs active ref now). The cert no longer touches the LeiosNotify level. + - `CertSide` → **`ChainSyncSide HeaderHash`**, now held in the separate `Election ↦ ChainSyncSide` + map (split out of the `EbHashMap` so its election side carries no payload; **dropped the EbHash** — + the EbHash is the Refs active ref now). The cert no longer touches the LeiosNotify level. The + recorded HeaderHash is now **read** (per-peer cert-conflict check, see §3), no longer write-only. - per-EB **`Any`** flag = "this EB was ChainSync-offered (cert via LevRollForward)"; kept distinct from the LeiosNotify level so `RedundantOffer` only consults the latter. - **`effectiveOffer`** = LeiosNotify level ⊔ (`Any` ⇒ body+closure), per-EB, no election scan. @@ -120,8 +138,15 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — `LstVolatileClosure` (+ closure offers + `NotifyVotingAndChainSel` per naming election). Completion is per-EbHash (`completeEb`), not per-election. - [ ] **`LevRollForward` cert bit / `recordChainSyncSide`**: `supersede` sets the per-EB `Any` ChainSync - flag (leaving the LeiosNotify level untouched) + per-election `Just (ChainSyncSide hh)`; guarded - against a repeat cert. Spec records `These (Cert …) BodyAndClosure`. + flag (leaving the LeiosNotify level untouched) + inserts `ChainSyncSide hh` into the per-election + `Election ↦ ChainSyncSide` map; guarded against a repeat cert. Spec records `These (Cert …) BodyAndClosure`. +- [ ] **`CertConflict` now also fires on a peer's *own* prior certified HeaderHash.** A certified + HeaderHash is a quorum-backed, unique-per-election fact, so a peer asserting two **different + certified** HeaderHashes for one election (two cert-carrying `LevRollForward`s) is provably lying — + `rollForwardCert` disconnects if the offered `atHeaderHash` conflicts with **either** our validated + `LstCertified` cert (the prior check) **or** the peer's own recorded `ChainSyncSide` for that + election. (Two *uncertified* announcements for one election remain ordinary equivocation — recorded + via the equiv machinery, never a disconnect; an honest peer can relay producer equivocation.) - [ ] **`LevCertValidated`**: uses `supersede` into the `EbHashMap` (and `deleteElection` when already complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 500a5e9b04..8d0345d795 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -182,6 +182,14 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , offer (Peer 1) (EbHash 101) ] assertBool "disconnects (unannounced offer)" (Disconnect (Peer 1) UnannouncedOffer `elem` fx) + , testCase "BEH-Offers: two different certified HeaderHashes for one election disconnects; a repeat does not" $ do + let certRf hh eb = LevRollForward (Peer 1) (RbHeader (HeaderHash hh) el100 Nothing True True) + (Just (AnnouncementTriple el100 (HeaderHash hh) (EbHash eb))) + (_, fxConflict) = run [ LevPeerAdd (Peer 1) StakeSampled, certRf 10 100, certRf 11 100 ] + (_, fxRepeat) = run [ LevPeerAdd (Peer 1) StakeSampled, certRf 10 100, certRf 10 100 ] + assertBool "disconnects with CertConflict" (Disconnect (Peer 1) CertConflict `elem` fxConflict) + assertBool "an identical certified claim is idempotent" (not (any isDisconnect fxRepeat)) + , testCase "BEH-Responses: a body whose closure size mismatches the announcement disconnects" $ do let badBody = Body (EbHash 100) [TxRef (TxHash 1) 1] 200 (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) @@ -249,14 +257,14 @@ tests = testGroup "Leios RefModel — Spec.md main spec" ehB = EbHash 11 ehC = EbHash 12 ehD = EbHash 13 - m0 = empty :: EbHashMap [Int] () - m1 = upsert ehA el1 [1] () m0 - m2 = upsert ehA el2 [2] () m1 -- second election names ehA: incRef combines - m3 = upsert ehA el1 [3] () m2 -- re-upsert same active: adjust combines - m4 = supersede el1 ehB [9] () m3 -- el1 switches to ehB; ehA untouched, now el1's inactive + m0 = empty :: EbHashMap [Int] + m1 = upsert ehA el1 [1] m0 + m2 = upsert ehA el2 [2] m1 -- second election names ehA: incRef combines + m3 = upsert ehA el1 [3] m2 -- re-upsert same active: adjust combines + m4 = supersede el1 ehB [9] m3 -- el1 switches to ehB; ehA untouched, now el1's inactive m5 = fromMaybe m4 (updateEb ehA (Just . (<> [4])) m4) - mC = supersede el3 ehC [6] () (upsert ehC el3 [5] () m5) -- supersede with active==eh combines - m = supersede el4 ehD [7] () mC -- supersede before any upsert + mC = supersede el3 ehC [6] (upsert ehC el3 [5] m5) -- supersede with active==eh combines + m = supersede el4 ehD [7] mC -- supersede before any upsert lookupEb ehA m @?= Just (RefCounts 1 1 [1, 2, 3, 4]) -- el2 active, el1 now inactive lookupEb ehB m @?= Just (RefCounts 1 0 [9]) lookupEb ehC m @?= Just (RefCounts 1 0 [5, 6]) @@ -269,8 +277,8 @@ tests = testGroup "Leios RefModel — Spec.md main spec" -- | A random operation over a small key space (so collisions, supersessions, -- and shared EbHashes across elections are common). data Op - = OpInsert Election EbHash Int Int - | OpSupersede Election EbHash Int Int + = OpInsert Election EbHash Int + | OpSupersede Election EbHash Int | OpDelete Election | OpPrune Slot deriving Show @@ -284,44 +292,44 @@ genEbHash = EbHash . fromIntegral <$> chooseInt (0, 4) instance Arbitrary Op where arbitrary = oneof - [ OpInsert <$> genElection <*> genEbHash <*> arbitrary <*> arbitrary - , OpSupersede <$> genElection <*> genEbHash <*> arbitrary <*> arbitrary + [ OpInsert <$> genElection <*> genEbHash <*> arbitrary + , OpSupersede <$> genElection <*> genEbHash <*> arbitrary , OpDelete <$> genElection , OpPrune . Slot . fromIntegral <$> chooseInt (0, 6) ] -activeOf :: Election -> EbHashMap a b -> Maybe EbHash +activeOf :: Election -> EbHashMap a -> Maybe EbHash activeOf el m = activeRef <$> lookupElection el m -- | The ops error on misuse; only apply each when its precondition holds. -insertValid :: Election -> EbHash -> EbHashMap a b -> Bool +insertValid :: Election -> EbHash -> EbHashMap a -> Bool insertValid el eh m = maybe True (== eh) (activeOf el m) -supersedeValid :: Election -> EbHash -> EbHashMap a b -> Bool +supersedeValid :: Election -> EbHash -> EbHashMap a -> Bool supersedeValid el _ m = case lookupElection el m of - Nothing -> True -- cert before announcement - Just (Refs NoInactiveRefYet _ _) -> True -- first cert for this election - Just (Refs NoInactiveRef _ _) -> False -- already superseded - Just (Refs (InactiveRef _) _ _) -> False -- already superseded + Nothing -> True -- cert before announcement + Just (Refs NoInactiveRefYet _) -> True -- first cert for this election + Just (Refs NoInactiveRef _) -> False -- already superseded + Just (Refs (InactiveRef _) _) -> False -- already superseded -apply :: Op -> EbHashMap (Sum Int) (Sum Int) -> EbHashMap (Sum Int) (Sum Int) +apply :: Op -> EbHashMap (Sum Int) -> EbHashMap (Sum Int) apply op m = case op of - OpInsert el eh a b -> if insertValid el eh m then upsert eh el (Sum a) (Sum b) m else m - OpSupersede el eh a b -> if supersedeValid el eh m then supersede el eh (Sum a) (Sum b) m else m - OpDelete el -> deleteElection el m - OpPrune s -> pruneElections (\e -> electionSlot e < s) m + OpInsert el eh a -> if insertValid el eh m then upsert eh el (Sum a) m else m + OpSupersede el eh a -> if supersedeValid el eh m then supersede el eh (Sum a) m else m + OpDelete el -> deleteElection el m + OpPrune s -> pruneElections (\e -> electionSlot e < s) m -electionsOf :: EbHashMap a b -> [Election] +electionsOf :: EbHashMap a -> [Election] electionsOf (EbHashMap _ els) = Map.keys els -postcond :: Op -> EbHashMap (Sum Int) (Sum Int) -> EbHashMap (Sum Int) (Sum Int) -> Bool +postcond :: Op -> EbHashMap (Sum Int) -> EbHashMap (Sum Int) -> Bool postcond op pre post = case op of - OpInsert el eh _ _ -> case lookupElection el pre of -- a fresh announce sets the active - Nothing -> activeOf el post == Just eh - _ -> True - OpSupersede el eh _ _ -> not (supersedeValid el eh pre) || activeOf el post == Just eh - OpDelete el -> isNothing (lookupElection el post) - OpPrune s -> all (\e -> not (electionSlot e < s)) (electionsOf post) + OpInsert el eh _ -> case lookupElection el pre of -- a fresh announce sets the active + Nothing -> activeOf el post == Just eh + _ -> True + OpSupersede el eh _ -> not (supersedeValid el eh pre) || activeOf el post == Just eh + OpDelete el -> isNothing (lookupElection el post) + OpPrune s -> all (\e -> not (electionSlot e < s)) (electionsOf post) prop_ebHashMap :: [Op] -> Property prop_ebHashMap = go empty From 060ce800dd2a5272968b428ace12ca159bc995b3 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 09:19:19 -0400 Subject: [PATCH 09/16] WIP addressing Claude's first review --- .../Test/Leios/RefModel/RefModel.hs | 205 +++++++++++------- .../Test/Leios/RefModel/SPEC-DRIFT.md | 26 +++ .../Test/Leios/RefModel/Spec.md | 4 +- .../Test/Leios/RefModel/test/RefModelTest.hs | 83 ++++++- 4 files changed, 238 insertions(+), 80 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 96c0a2cf45..db71bc26c7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -49,9 +49,6 @@ data RbHeader = RbHeader -- §Conventions · §3 LevRoll } deriving (Eq, Ord, Show) -election :: RbHeader -> Election -- §Conventions election(header) -election = rbElection - data TxRef = TxRef { txRefHash :: TxHash, txRefSize :: ByteCount } -- §Conventions tx (hash + size) deriving (Eq, Ord, Show) @@ -97,7 +94,7 @@ data LeiosNotifySide = LeiosNotifySide OfferLevel Time -- §2 LstPeerOfferings: offerLevel :: LeiosNotifySide -> OfferLevel offerLevel (LeiosNotifySide lvl _) = lvl -instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings (tuple-Semigroup requirement; never merges two reals at runtime) +instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings (tuple-Semigroup requirement; TODO unreachable) LeiosNotifySide l1 t1 <> LeiosNotifySide l2 t2 = LeiosNotifySide (max l1 l2) (max t1 t2) data ChainSyncSide = ChainSyncSide HeaderHash -- §2 LstPeerOfferings / ChainSyncSide @@ -155,6 +152,13 @@ data Req -- §2 LstPeerInflight / Req | ReqJob EbHash JobId Job -- the job itself, for validation deriving (Eq, Ord, Show) +data MiniProtocol = FetchBody | FetchTxs -- §2 LeiosFetch sub-protocols (independent response FIFOs) + deriving (Eq, Ord, Show) + +reqProtocol :: Req -> MiniProtocol -- §2 LstPeerInflight: a Req's LeiosFetch sub-protocol +reqProtocol ReqBody{} = FetchBody +reqProtocol ReqJob{} = FetchTxs + data PeerInfo = PeerInfo { peerClass :: Class, peerPhase :: Phase } -- §2 LstPeerPresent deriving (Eq, Show) @@ -181,7 +185,7 @@ data St = St , stVolatileBody :: !(EbHashMap ()) -- §2 LstVolatileBody , stVolatileClosure :: !(EbHashMap ()) -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified - , stPeerInflight :: !(Peer :-> (Seq Req)) -- §2 LstPeerInflight + , stPeerInflight :: !(Peer :-> MiniProtocol :-> Seq Req) -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent } deriving (Eq, Show) @@ -209,6 +213,7 @@ data Env = Env , envPeerSharingMaxActiveEbs :: Int -- §2 peerSharingMaxActiveEbs , envPeerSharingClosureByteLimit :: ByteCount -- §2 peerSharingClosureByteLimit , envJobSize :: ByteCount -- §2 jobSize + , envMaxTxSize :: ByteCount -- §2 maxTxSize (EB-body validation: no single tx may exceed it) , envRequestTimeout :: Word64 -- §2 requestTimeout , envNotifyMaxCapacity :: Int -- §2 notifyMaxCapacity , envNotifyStaleHorizon :: Word64 -- §2 notifyStaleHorizon (slots; ≈ 10 min) @@ -234,7 +239,8 @@ data LeiosDb m = LeiosDb -- §2 disk store interface } data TxCache m = TxCache -- §7 TxCache hooks - { txCacheNoteAnnouncement :: EbHash -> m () -- BEH-Wanting + { txCacheNoteAnnouncement :: Election -> EbHash -> m () -- BEH-Wanting + , txCacheEvictForValidCert :: Election -> EbHash -> m () -- BEH-Wanting , txCacheOnBody :: EbHash -> Set TxHash -> m [Tx] -- BEH-ChunkJobs , txCacheOnAcquire :: [Tx] -> m () -- BEH-Responses } @@ -263,7 +269,7 @@ data Stimulus -- §2 Stimuli | LevPeerAdd Peer Class -- BEH-PeerChurn | LevPeerWindDown Peer -- BEH-PeerChurn | LevPeerRemove Peer -- BEH-PeerChurn - | LevTimer Time Peer Req -- BEH-Timeout + | LevTimer Time Peer -- BEH-Timeout (a peer's reply-gap timer elapsed) | LevDiskDone DiskWrite -- §3 LevDiskDone (only writes signal completion) | LevImmTipAdvanced -- BEH-ImmTipAdvance (slot read from envImmutableTip) | LevGarbageCollect Slot -- BEH-ImmTipAdvance @@ -290,11 +296,11 @@ data Offence -- §3 disconnect reasons (c | UnannouncedOffer -- offered an EB the peer never first-announced | RedundantOffer -- an offer that raised no EB's LeiosNotify level | CertConflict -- certified HeaderHash conflicting with a known cert (ours, or the peer's own prior claim) for the election - | BodyMismatch -- body disagrees with the request (hash / size / closure size) + | BodyMismatch -- invalid body: hash / size / closure-size mismatch, or a tx exceeds envMaxTxSize | TxsMismatch -- closure txs disagree with the requested job (content or order) | UnsolicitedResponse -- a response matching no front in-flight request | RequestedAbsentData -- requested body/txs we do not hold - | RequestTimeout -- an in-flight request went overdue + | RequestTimeout -- a peer let envRequestTimeout elapse without replying while requests were outstanding | ExcessNotifyCredits -- extended more notify credits than notifyMaxCapacity allows | StaleNotification -- a LeiosNotify message whose slot is > notifyStaleHorizon below the immutable tip deriving (Eq, Ord, Show) @@ -303,8 +309,8 @@ data Effect -- §2 Actions = Send Peer WireMsg | Disconnect Peer Offence | SubmitDisk DiskOp - | SetTimer Peer Req Time - | NotifyVotingAndChainSel Election EbHash -- BEH-Completion (persisted closure → voting + ChainSel) + | SetTimer Peer Time -- BEH-Timeout: (re)arm a peer's reply-gap timer (replaces any prior) + | NotifyVotingAndChainSel EbHash [HeaderHash] -- BEH-Completion (closure available → voting + ChainSel; HeaderHashes of announcing RBs, immtip-or-newer, that ChainSel maps to the unblocked CertRBs via successors) | NotifyEnqueue Peer -- BEH-NotifyServe deriving (Eq, Show) @@ -314,8 +320,11 @@ classOf st peer = (\pi_ -> (peerClass pi_, peerPhase pi_)) <$> Map.lookup peer ( activePeers :: St -> [Peer] -- NEEDS-TO-BE-INCREMENTAL: maintained set of Active peers activePeers st = [ peer | (peer, pi_) <- Map.toList (stPeerPresent st), peerPhase pi_ == Active ] -inflightOf :: St -> Peer -> Seq Req -inflightOf st peer = fromMaybe Seq.empty (Map.lookup peer (stPeerInflight st)) +inflightOf :: St -> Peer -> Seq Req -- all in-flight Reqs to a peer (across sub-protocols) +inflightOf st peer = mconcat (Map.elems (fromMaybe Map.empty (Map.lookup peer (stPeerInflight st)))) + +inflightFifo :: St -> Peer -> MiniProtocol -> Seq Req -- §2 LstPeerInflight: one sub-protocol's FIFO +inflightFifo st peer mp = fromMaybe Seq.empty (Map.lookup mp =<< Map.lookup peer (stPeerInflight st)) inflightHas :: St -> Peer -> Req -> Bool -- NEEDS-TO-BE-INCREMENTAL: per-peer requested-Req set inflightHas st peer r = r `elem` inflightOf st peer @@ -329,7 +338,8 @@ reqEb (ReqJob eh _ _) = eh jobInflightPeers :: St -> EbHash -> JobId -> Int -- §2 jobInflightPeers · NEEDS-TO-BE-INCREMENTAL: (EbHash,JobId)↦in-flight-peer-count index jobInflightPeers st eh j = - length [ () | (_, sq) <- Map.toList (stPeerInflight st) + length [ () | sqs <- Map.elems (stPeerInflight st) + , sq <- Map.elems sqs , ReqJob eh' j' _ <- toList sq , eh' == eh, j' == j ] @@ -347,8 +357,10 @@ jobBytes st eh j = wantStateOf :: St -> EbHash -> Maybe WantState -- §2 LstWanted wantStateOf st eh = (\(EM.RefCounts _ _ ws) -> ws) <$> EM.lookupEb eh (stWanted st) -wantsEh :: St -> EbHash -> Bool -- §2 LstWanted -wantsEh st eh = isJust (EM.lookupEb eh (stWanted st)) +activelyWantsEh :: St -> EbHash -> Bool -- §2 LstWanted (the EB is some election's active want) +activelyWantsEh st eh = case EM.lookupEb eh (stWanted st) of + Just (EM.RefCounts act _ _) -> act > 0 + Nothing -> False wantedEbs :: St -> [EbHash] -- §2 LstWanted · NEEDS-TO-BE-INCREMENTAL: maintained wanted-EB set wantedEbs st = let EM.EbHashMap ebs _ = stWanted st in Map.keys (Map.filter (\(EM.RefCounts act _ _) -> 0 < act) ebs) @@ -487,20 +499,29 @@ step ifs env now stim st = case stim of LevWiredMsg peer msg -> stepWired ifs env now peer msg st LevRollForward peer h pe -> hRollForward ifs env now peer h pe st LevCertValidated at bs cs -> hCertValidated ifs env now at bs cs st - LevPeerAdd peer cls -> hPeerAdd peer cls st + LevPeerAdd peer cls -> hPeerAdd env peer cls st LevPeerWindDown peer -> hPeerWindDown env now peer st LevPeerRemove peer -> hPeerRemove env now peer st - LevTimer _ peer req -> hTimer peer req st + LevTimer _ peer -> hTimer peer st LevDiskDone w -> hDiskDone ifs env now w st LevImmTipAdvanced -> hImmTipAdvanced env st LevGarbageCollect s -> hGarbageCollect s st LevSelfIssued h body -> hSelfIssued ifs env now h body st LevNotifyDequeue peer -> hNotifyDequeue env peer st -stepWired :: Monad m => Ifaces m -> Env -> Time -> Peer -> WireMsg -> St -> m (St, [Effect]) -stepWired ifs env now peer msg st - | Just s <- notifyMsgSlot st peer msg, notifyStale env s = pure (st, [Disconnect peer StaleNotification]) - | otherwise = case msg of +stepWired :: Monad m => Ifaces m -> Env -> Time -> Peer -> WireMsg -> St -> m (St, [Effect]) -- §3 (notify client: refill one RequestNext per consumed notification, unless winding down) +stepWired ifs env now peer msg st = case notifyMsgSlot st peer msg of + Just s | notifyStale env s -> pure (st, [Disconnect peer StaleNotification]) + mslot -> do + (st', fx) <- dispatch + pure (st', fx ++ [ Send peer MsgLeiosNotificationRequestNext | isJust mslot, active ] + ++ [ armTimer env now peer | fetchResponse msg ]) + where + active = case classOf st peer of Just (_, Active) -> True; _ -> False + fetchResponse MsgLeiosBlock{} = True + fetchResponse MsgLeiosBlockTxs{} = True + fetchResponse _ = False + dispatch = case msg of MsgLeiosNotificationRequestNext -> hRequestNext env peer st MsgLeiosBlockAnnouncement h -> hAnnouncement ifs env now peer h st MsgLeiosBlockEquivocationProof m1 h2 -> hEquivProof env peer m1 h2 st @@ -514,14 +535,12 @@ stepWired ifs env now peer msg st hAnnouncement :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockAnnouncement hAnnouncement ifs env now peer h st = case rbAnnounce h of Nothing -> pure (st, [Disconnect peer NotAnAnnouncement]) - Just ann + Just _ | not (rbValid h) -> pure (st, [Disconnect peer InvalidHeader]) | otherwise -> case advancePeerAnn peer (rbElection h) h st of Nothing -> pure (st, [Disconnect peer AnnouncementBound]) - Just st1 -> do - txCacheNoteAnnouncement (ifTxc ifs) (annEbHash ann) - centralAnnounce ifs env now h (copyAnnIntoOfferings peer (rbElection h) st1) + Just st1 -> centralAnnounce ifs env now h (copyAnnIntoOfferings peer (rbElection h) st1) hEquivProof :: Monad m => Env -> Peer -> Maybe RbHeader -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockEquivocationProof hEquivProof env peer mh1 h2 st = @@ -709,14 +728,20 @@ bumpGate peer eh lvl st = case EM.updateEb eh (\sent -> Just (sent <> Just lvl)) Nothing -> st where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) +validBody :: Env -> EbHash -> ByteCount -> ByteCount -> Body -> Bool -- BEH-Responses: EB-body validation (hash + sizes match the announcement; no single tx exceeds envMaxTxSize) +validBody env eh bs cs body = + bodyEbHash body == eh + && bodyActualSize body == bs + && sum (map txRefSize (bodyTxlist body)) == cs + && all ((<= envMaxTxSize env) . txRefSize) (bodyTxlist body) + hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock -hBlock ifs env now peer eh body st = case frontReq st peer of +hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of Just (ReqBody eh' bs cs) | eh' == eh -> - let st1 = popFront peer st - closureBytes = sum (map txRefSize (bodyTxlist body)) - in if bodyEbHash body /= eh || bodyActualSize body /= bs || closureBytes /= cs + let st1 = popFront peer FetchBody st + in if not (validBody env eh bs cs body) then pure (st1, [Disconnect peer BodyMismatch]) - else if not (wantsEh st eh) + else if not (activelyWantsEh st eh) then considerFetchAfter env now st1 [] else do let txrefs = bodyTxlist body @@ -735,20 +760,22 @@ hBlock ifs env now peer eh body st = case frontReq st peer of _ -> pure (st, [Disconnect peer UnsolicitedResponse]) hBlockTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> [Tx] -> St -> m (St, [Effect]) -- BEH-Responses · §3 LevBlockTxs -hBlockTxs ifs env now peer eh txs st = case frontReq st peer of +hBlockTxs ifs env now peer eh txs st = case frontReq st peer FetchTxs of Just (ReqJob eh' j job) | eh' == eh -> - let st1 = popFront peer st + let st1 = popFront peer FetchTxs st in if map txHash txs /= NE.toList (jobTxs job) then pure (st1, [Disconnect peer TxsMismatch]) - else do - txCacheOnAcquire (ifTxc ifs) txs - let writes = [SubmitDisk (Write (WriteClosure eh txs))] - case wantStateOf st1 eh of - Just (AwaitingTxs t) -> - let jobs' = Map.delete j (txsFetch t) - st2 = setTxs eh jobs' (txsWrites t + 1) st1 - in considerFetchAfter env now st2 writes - _ -> considerFetchAfter env now st1 writes + else if not (activelyWantsEh st1 eh) + then considerFetchAfter env now st1 [] + else do + txCacheOnAcquire (ifTxc ifs) txs + let writes = [SubmitDisk (Write (WriteClosure eh txs))] + case wantStateOf st1 eh of + Just (AwaitingTxs t) -> + let jobs' = Map.delete j (txsFetch t) + st2 = setTxs eh jobs' (txsWrites t + 1) st1 + in considerFetchAfter env now st2 writes + _ -> considerFetchAfter env now st1 writes _ -> pure (st, [Disconnect peer UnsolicitedResponse]) hServeBody :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockRequest @@ -767,18 +794,19 @@ hServeTxs ifs _env _now peer eh txs st = do hCertValidated :: Monad m => Ifaces m -> Env -> Time -> AnnouncementTriple -> ByteCount -> ByteCount -> St -> m (St, [Effect]) -- BEH-Wanting · BEH-FetchPriority · §3 LevCertValidated hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st = do + txCacheEvictForValidCert (ifTxc ifs) el eh let st1 = setCertified el (hh, eh) st done <- isComplete ifs eh - let st2 | belowTip env el = st1 - | done = removeWantEl el st1 - | otherwise = supersedeWant el eh bs cs st1 - considerFetchAfter env now st2 [] + let (st2, fx) | belowTip env el = (st1, []) + | done = recordCompleteCert env el eh st1 + | otherwise = (supersedeWant el eh bs cs st1, []) + considerFetchAfter env now st2 fx -hPeerAdd :: Monad m => Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd -hPeerAdd peer cls st = pure +hPeerAdd :: Monad m => Env -> Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd (prime the notify client: envNotifyMaxCapacity RequestNext) +hPeerAdd env peer cls st = pure ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) , stPeerOfferings = Map.insert peer emptyPeerOfferings (stPeerOfferings st) } - , [] ) + , replicate (envNotifyMaxCapacity env) (Send peer MsgLeiosNotificationRequestNext) ) hPeerWindDown :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerWindDown hPeerWindDown env now peer st = @@ -795,32 +823,51 @@ hPeerRemove env now peer st = , stPeerInflight = Map.delete peer (stPeerInflight st) } in considerFetchAfter env now st1 [] -hTimer :: Monad m => Peer -> Req -> St -> m (St, [Effect]) -- BEH-Timeout · §3 LevTimer -hTimer peer req st = pure (st, [Disconnect peer RequestTimeout | inflightHas st peer req]) +hTimer :: Monad m => Peer -> St -> m (St, [Effect]) -- BEH-Timeout · §3 LevTimer (disconnect iff still expecting replies) +hTimer peer st = pure (st, [Disconnect peer RequestTimeout | not (Seq.null (inflightOf st peer))]) hDiskDone :: Monad m => Ifaces m -> Env -> Time -> DiskWrite -> St -> m (St, [Effect]) -- §3 LevDiskDone · BEH-Completion -hDiskDone _ifs _env _now w st = case w of +hDiskDone _ifs env _now w st = case w of WriteBody body -> let eh = bodyEbHash body st0 = st { stVolatileBody = addVolatile eh (electionsNaming eh st) (stVolatileBody st) } (st1, fx1) = enqueueBodyOffers eh st0 - (st2, fx2) = decWrite eh st1 + (st2, fx2) = decWrite env eh st1 in pure (st2, fx1 ++ fx2) - WriteClosure eh _ -> pure (decWrite eh st) + WriteClosure eh _ -> pure (decWrite env eh st) -decWrite :: EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) -decWrite eh st = case wantStateOf st eh of +decWrite :: Env -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) +decWrite env eh st = case wantStateOf st eh of Just (AwaitingTxs t) -> case decTxsState t of Just t' -> (updateWant eh (\_ -> Just (AwaitingTxs t')) st, []) - Nothing -> completeEb eh st + Nothing -> completeEb env eh st _ -> (st, []) -completeEb :: EbHash -> St -> (St, [Effect]) -- BEH-Completion (per-EbHash; fan out to every interested election) -completeEb eh st = +annStateHeaders :: AnnState -> [RbHeader] -- §2 LstFirstAnnouncements: the RbHeaders recorded for an election +annStateHeaders (AnnOne h) = [h] +annStateHeaders (AnnTwo h1 h2) = [h1, h2] + +announcingHeaderHashes :: Env -> EbHash -> St -> [HeaderHash] -- BEH-Completion · NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦announcing-RB index (immtip-or-newer) +announcingHeaderHashes env eh st = + [ rbHeaderHash h + | (el, ann) <- Map.toList (stFirstAnnouncements st) + , not (belowTip env el) + , h <- annStateHeaders ann + , annEbHashOf h == Just eh ] + +completeEb :: Env -> EbHash -> St -> (St, [Effect]) -- BEH-Completion (per-EbHash; notify voting + ChainSel with the announcing RBs) +completeEb env eh st = let els = electionsNaming eh st st0 = st { stVolatileClosure = addVolatile eh els (stVolatileClosure st) } (st1, fx) = enqueueClosureOffers eh (removeWantEb eh st0) - in (st1, [ NotifyVotingAndChainSel el eh | el <- els ] ++ fx) + in (st1, NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st) : fx) + +recordCompleteCert :: Env -> Election -> EbHash -> St -> (St, [Effect]) -- BEH-Completion: a cert for an already-complete EB (incl. restart) makes its closure available +recordCompleteCert env el eh st = + let st1 = removeWantEl el st + st2 = st1 { stVolatileBody = addVolatile eh [el] (stVolatileBody st1) + , stVolatileClosure = addVolatile eh [el] (stVolatileClosure st1) } + in (st2, [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st2) ]) hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced hImmTipAdvanced env st = @@ -855,8 +902,10 @@ considerFetching env now st = pure (foldl' go (st, []) (activePeers st)) where go (s, fx) peer = let new = decide env s peer + wasIdle = Seq.null (inflightOf s peer) s' = foldl' (issue peer) s new - fx' = fx ++ concatMap (sendReq s now peer) new + fx' = fx ++ concatMap (sendReq s peer) new + ++ [ armTimer env now peer | wasIdle, not (null new) ] in (s', fx') considerFetchAfter :: Monad m => Env -> Time -> St -> [Effect] -> m (St, [Effect]) @@ -866,22 +915,25 @@ considerFetchAfter env now st fx = do issue :: Peer -> St -> Req -> St issue peer st r = - st { stPeerInflight = Map.insertWith (flip (<>)) peer (Seq.singleton r) (stPeerInflight st) } + st { stPeerInflight = Map.insertWith (Map.unionWith (flip (<>))) peer (Map.singleton (reqProtocol r) (Seq.singleton r)) (stPeerInflight st) } + +sendReq :: St -> Peer -> Req -> [Effect] -- §3 issue a request +sendReq st peer r = [Send peer (reqWire st r)] -sendReq :: St -> Time -> Peer -> Req -> [Effect] -sendReq st now peer r = [Send peer (reqWire st r), SetTimer peer r now] +armTimer :: Env -> Time -> Peer -> Effect -- §2 requestTimeout: (re)arm peer's reply-gap timer at now + envRequestTimeout +armTimer env (Time now) peer = SetTimer peer (Time (now + envRequestTimeout env)) reqWire :: St -> Req -> WireMsg reqWire _ (ReqBody eh _ _) = MsgLeiosBlockRequest eh reqWire _ (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobTxs job) -frontReq :: St -> Peer -> Maybe Req -frontReq st peer = case inflightOf st peer of +frontReq :: St -> Peer -> MiniProtocol -> Maybe Req +frontReq st peer mp = case inflightFifo st peer mp of r :<| _ -> Just r _ -> Nothing -popFront :: Peer -> St -> St -popFront peer st = st { stPeerInflight = Map.adjust dropFront peer (stPeerInflight st) } +popFront :: Peer -> MiniProtocol -> St -> St +popFront peer mp st = st { stPeerInflight = Map.adjust (Map.adjust dropFront mp) peer (stPeerInflight st) } where dropFront sq = case sq of _ :<| rest -> rest; Empty -> Empty wantBody :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (announcement; keep existing progress if already wanted) @@ -956,21 +1008,25 @@ advancePeerAnn peer el h st = (stPeerFirstAnnouncements st) } centralAnnounce :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> St -> m (St, [Effect]) -- §3 LevBlockAnnouncement central branch -centralAnnounce _ifs env _now h st = case rbAnnounce h of +centralAnnounce ifs env _now h st = case rbAnnounce h of Nothing -> pure (st, []) Just ann -> let el = rbElection h eh = annEbHash ann in case Map.lookup el (stFirstAnnouncements st) of - Nothing -> + Nothing -> do + txCacheNoteAnnouncement (ifTxc ifs) el eh let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } + nowAvailable = heldIn eh (stVolatileClosure st1) + && not (belowTip env el) + && (EM.activeRef <$> EM.lookupElection el (stVolatileClosure st1)) /= Just eh st2 = anchorVolatile el eh st1 st3 | belowTip env el = st2 | heldIn eh (stVolatileClosure st2) = st2 | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 (st5, fx') = enqueueHeldOffers eh st4 - in pure (st5, fx ++ fx') + pure (st5, fx ++ fx' ++ [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st1) | nowAvailable ]) Just (AnnOne h1) | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) | otherwise -> @@ -1009,7 +1065,8 @@ nullIfaces = Ifaces { ifDb = LeiosDb { dbQueryPresent = const (pure Set.empty) , dbReadBody = const (pure Nothing) , dbReadClosureTxs = \_ _ -> pure [] } - , ifTxc = TxCache { txCacheNoteAnnouncement = const (pure ()) + , ifTxc = TxCache { txCacheNoteAnnouncement = \_ _ -> pure () + , txCacheEvictForValidCert = \_ _ -> pure () , txCacheOnBody = \_ _ -> pure [] , txCacheOnAcquire = const (pure ()) } , ifMem = Mempool { mempoolQueryPresent = const (pure []) } @@ -1040,5 +1097,5 @@ prop_inflightOffered st = and [ case r of ReqBody eh _ _ -> peer `Set.member` offerersBody st eh ReqJob eh _ _ -> peer `Set.member` offerersClosure st eh - | (peer, sq) <- Map.toList (stPeerInflight st) - , r <- toList sq ] + | peer <- Map.keys (stPeerInflight st) + , r <- toList (inflightOf st peer) ] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md index 311555b4b8..f1b68f851b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md @@ -150,6 +150,32 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — - [ ] **`LevCertValidated`**: uses `supersede` into the `EbHashMap` (and `deleteElection` when already complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. +## §7 TxCache occupancy (equivocation-resistant) + +- [ ] **Note once per election, at the central chokepoint.** `txCacheNoteAnnouncement` moved from the + per-peer ingress (`hAnnouncement`) to `centralAnnounce`'s first-announcement branch (the `Nothing` + case that sets `AnnOne`). Bugfix: at the ingress it fired once *per peer*, so K adversary connections + announcing K distinct EBs for one election forced K cache reservations (on-disk tx bytes), capped only + per-peer — *upstream* of the central one-per-election cap. Now the cache sees exactly + `LstFirstAnnouncements[el]`. Side-effect: rollforward-carried and self-issued announcements now prime + the cache too (they route through `centralAnnounce`), which the per-peer placement had missed. +- [ ] **Cache hooks are election-keyed.** `txCacheNoteAnnouncement :: Election -> EbHash -> m ()` (was + `EbHash -> m ()`) so the cache can maintain the per-election index; the reference-awareness for an + EbHash shared across elections lives inside the cache (where the tx storage is), not in the model. +- [ ] **New hook `txCacheEvictForValidCert :: Election -> EbHash -> m ()`.** Called in `hCertValidated` on + every valid cert, with the certified EbHash. Semantics: "election `el` is certified to `eh`; evict any + tx data retained for `el`'s *other* (superseded) EB." Bounds on-disk to one EB per election at all + times (transient two only during the switch): pre-cert the index tracks the first-announced; a cert to + a different EB evicts the uncertified first-announcement. "Equivocate and never certify" is already + handled by the note-once rule (only the first is ever retained). +- [ ] **Acquire is gated by the *active* want.** `hBlock` and `hBlockTxs` only touch the cache (and persist + the closure) when the EB is some election's **active** want — new `activelyWantsEh` (active refcount + `> 0`, replacing the old `wantsEh = isJust`, which also counted an inactive/superseded ref). Without + this, a late response for a job requested *before* a cert-switch/eviction would re-acquire the dead + EB's txs (and write its closure), undoing the eviction — and an adversary can time exactly that. + `hBlockTxs` previously had no want-guard at all on `txCacheOnAcquire`/`WriteClosure`; `hBlock` had an + `isJust` guard, now tightened to the active test for symmetry. + ## §4 Properties - [ ] "Offers are announced or certified" now keys off the EbHashMap supersede state diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md index 9eeb7131f3..1ee9fd6ca6 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/Spec.md @@ -977,12 +977,12 @@ TxCache keeps a far tighter recent window), so the two are GC'd independently. The main spec touches it only through these hooks: -- **`txCacheNoteAnnouncement(eb)`** — `LevBlockAnnouncement` calls this for every accepted announcement; the cache +- **`txCacheNoteAnnouncement(eb)`** — `LevBlockAnnouncement` calls this for every accepted announcement (TODO correction: it starts as only the first-announcement per election and might change to a certified announcement for that election if that's different); the cache applies its own qualifying filter (below) and advances its window. - **`txCacheOnBody(eb, txset(eb)) → hits`** — `BEH-ChunkJobs` calls this when the body arrives; it returns the cached (already acquired) txs so they're not re-fetched, and records that `eb` references `txset(eb)`. - **`txCacheOnAcquire(txs)`** — called when some txs' bytes arrive (`LevBlockTxs`, or a Mempool hit); for each - tx the cache is still tracking (`refcount > 0` — some eligible in-window EB references it) it marks + tx the cache is still tracking (`refcount > 0` — some eligible in-window EB (TODO correction: announcement) references it) it marks `acquired` and stores the bytes; a tx no eligible in-window EB references is ignored (not stored). - **`dbCopyFromTxCache(txs)`** — copy hit bytes from the cache's backing store into the requesting EB's LeiosDB closure. diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 8d0345d795..002a790388 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -1,6 +1,8 @@ module Main (main) where +import Control.Monad (foldM) import Data.Functor.Identity (Identity, runIdentity) +import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (foldl') import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -19,7 +21,7 @@ main :: IO () main = defaultMain tests env :: Env -env = Env 5 2 1000000 65536 30 300 600 21600 (Slot 0) +env = Env 5 2 1000000 65536 16384 30 300 600 21600 (Slot 0) el100 :: Election el100 = Election (Slot 5) (PoolId 1) @@ -76,11 +78,21 @@ isDisconnect _ = False tests :: TestTree tests = testGroup "Leios RefModel — Spec.md main spec" - [ testCase "BEH-PeerChurn: LevPeerAdd registers an Active peer, no effects" $ do + [ testCase "BEH-PeerChurn: LevPeerAdd registers an Active peer and primes the notify client" $ do let (st, fx) = run [LevPeerAdd (Peer 1) StakeSampled] - fx @?= [] + fx @?= replicate (envNotifyMaxCapacity env) (Send (Peer 1) MsgLeiosNotificationRequestNext) fmap peerPhase (Map.lookup (Peer 1) (stPeerPresent st)) @?= Just Active + , testCase "BEH-NotifyServe (client): a consumed notification refills one RequestNext" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 ] + reqNexts = length [ () | Send _ MsgLeiosNotificationRequestNext <- fx ] + reqNexts @?= envNotifyMaxCapacity env + 1 + + , testCase "BEH-NotifyServe (client): no refill for a WindingDown peer" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerWindDown (Peer 1), ann (Peer 1) hdr100 ] + reqNexts = length [ () | Send _ MsgLeiosNotificationRequestNext <- fx ] + reqNexts @?= envNotifyMaxCapacity env + , testCase "BEH-Wanting: an announcement gates the want (AwaitingBody), no fetch yet" $ do let (st, fx) = run [LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100] wantStateOf st (EbHash 100) @?= Just (AwaitingBody 200 300) @@ -97,6 +109,17 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "want advanced to AwaitingTxs" (case wantStateOf st (EbHash 100) of Just AwaitingTxs{} -> True; _ -> False) + , testCase "BEH-Responses: body and txs responses use separate per-mini-protocol FIFOs" $ do + let body200 = Body (EbHash 200) [TxRef (TxHash 9) 300] 200 + offer200 = LevWiredMsg (Peer 1) (MsgLeiosBlockTxsOffer (Slot 6) (EbHash 200)) + (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled + , ann (Peer 1) hdr200, offer200 + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 200) body200) -- eh200 -> AwaitingTxs: a ReqJob is now in flight + , ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) -- a ReqBody for eh100 is now in flight + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] -- the body response must not be blocked behind the ReqJob + assertBool "a body response is not blocked behind an in-flight txs request" (not (any isDisconnect fx)) + assertBool "eh100 advanced to AwaitingTxs" (case wantStateOf st (EbHash 100) of Just AwaitingTxs{} -> True; _ -> False) + , testCase "Job: jobBytes is the real summed tx size" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] @@ -190,12 +213,43 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "disconnects with CertConflict" (Disconnect (Peer 1) CertConflict `elem` fxConflict) assertBool "an identical certified claim is idempotent" (not (any isDisconnect fxRepeat)) + , testCase "BEH-Wanting: TxCache noted once per election (first-announced); a superseding cert evicts" $ do + ref <- newIORef ([] :: [(String, Election, EbHash)]) + let recIfaces :: Ifaces IO + recIfaces = nullIfaces + { ifTxc = (ifTxc nullIfaces) + { txCacheNoteAnnouncement = \el eh -> modifyIORef' ref (("note", el, eh) :) + , txCacheEvictForValidCert = \el eh -> modifyIORef' ref (("evict", el, eh) :) } } + stimuli = [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) StakeSampled + , ann (Peer 1) hdr100, ann (Peer 2) hdr101 + , LevCertValidated (AnnouncementTriple el100 (HeaderHash 11) (EbHash 101)) 200 300 ] + _ <- foldM (\st s -> fst <$> step recIfaces env (Time 0) s st) emptySt stimuli + evs <- reverse <$> readIORef ref + [ (el, eh) | ("note", el, eh) <- evs ] @?= [ (el100, EbHash 100) ] + assertBool "a superseding cert evicts the election" (("evict", el100, EbHash 101) `elem` evs) + , testCase "BEH-Responses: a body whose closure size mismatches the announcement disconnects" $ do let badBody = Body (EbHash 100) [TxRef (TxHash 1) 1] 200 (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) badBody) ] assertBool "disconnects with BodyMismatch" (Disconnect (Peer 1) BodyMismatch `elem` fx) + , testCase "BEH-Responses: a body containing an oversized tx is rejected (BodyMismatch)" $ do + let bigHdr = RbHeader (HeaderHash 50) el100 (Just (EbAnn (EbHash 100) 200 20000)) False True + bigBody = Body (EbHash 100) [TxRef (TxHash 1) 20000] 200 + (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) bigHdr, offer (Peer 1) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) bigBody) ] + assertBool "disconnects with BodyMismatch (tx exceeds envMaxTxSize)" (Disconnect (Peer 1) BodyMismatch `elem` fx) + + , testCase "BEH-Timeout: a peer's timer disconnects (RequestTimeout) while requests are outstanding" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) + , LevTimer (Time 0) (Peer 1) ] + assertBool "disconnects with RequestTimeout" (Disconnect (Peer 1) RequestTimeout `elem` fx) + + , testCase "BEH-Timeout: a peer's timer with no outstanding requests does not disconnect" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevTimer (Time 0) (Peer 1) ] + assertBool "no disconnect when nothing is outstanding" (not (any isDisconnect fx)) + , testCase "BEH-Responses: an unsolicited body (no matching in-flight request) disconnects" $ do let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] @@ -213,6 +267,27 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [TxHash 1, TxHash 2])) ] [ ts | Send _ (MsgLeiosBlockTxs _ ts) <- fx ] @?= [[Tx (TxHash 1) 1, Tx (TxHash 2) 1]] + , testCase "BEH-Completion: a cert for an already-complete EB still fans voting + ChainSel" $ do + let ifs = nullIfaces { ifDb = (ifDb nullIfaces) + { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) + , dbQueryPresent = pure } } + el2 = Election (Slot 7) (PoolId 2) + (_, fx) = runWith ifs [ LevCertValidated (AnnouncementTriple el2 (HeaderHash 99) (EbHash 100)) 200 300 ] + assertBool "fans NotifyVotingAndChainSel for the (re)certified EB" + (NotifyVotingAndChainSel (EbHash 100) [] `elem` fx) + + , testCase "BEH-Completion: announcing an already-available closure under a new election fans voting + ChainSel" $ do + let ifs = nullIfaces { ifDb = (ifDb nullIfaces) + { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) + , dbQueryPresent = pure } } + e2 = Election (Slot 7) (PoolId 2) + e3 = Election (Slot 8) (PoolId 3) + hdrE3 = RbHeader (HeaderHash 78) e3 (Just (EbAnn (EbHash 100) 200 300)) False True + (_, fx) = runWith ifs [ LevCertValidated (AnnouncementTriple e2 (HeaderHash 99) (EbHash 100)) 200 300 + , LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdrE3 ] + assertBool "fans NotifyVotingAndChainSel carrying the new announcing RB's HeaderHash" + (NotifyVotingAndChainSel (EbHash 100) [HeaderHash 78] `elem` fx) + , testCase "BEH-Completion: finishing a body write enqueues a body offer" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) @@ -225,7 +300,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" setup = [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlockTxs (EbHash 100) txs) ] - exposed fx = NotifyVotingAndChainSel el100 (EbHash 100) `elem` fx + exposed fx = NotifyVotingAndChainSel (EbHash 100) [HeaderHash 10] `elem` fx (_, fx1) = run (setup ++ [ LevDiskDone (WriteBody body100) ]) (st2, fx2) = run (setup ++ [ LevDiskDone (WriteBody body100) , LevDiskDone (WriteClosure (EbHash 100) txs) ]) From a6f17be75ac02fbc2d4d404934a6a6d300e7707c Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 15:10:07 -0400 Subject: [PATCH 10/16] WIP addressing Claude's second review --- .../Test/Leios/RefModel/HeldEbHashSet.hs | 62 +++++++++++++++++++ .../Test/Leios/RefModel/RefModel.hs | 61 +++++++++--------- .../Test/Leios/RefModel/test/RefModelTest.hs | 15 +++++ 3 files changed, 109 insertions(+), 29 deletions(-) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs new file mode 100644 index 0000000000..ef4ed5d20f --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} + +module HeldEbHashSet ( + HeldEbHashSet + , empty + , insert + , member + , prune + ) where + +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Word (Word16) +import EbHashMap (EbHash, Election) + +-- | One or two, but no meaningful order +data Refs = Ref1 !EbHash | Ref2 !EbHash !EbHash + deriving (Eq, Show) + +newtype RefCount = + -- | INVARIANT positive + RefCount Word16 + deriving (Eq, Show) + +instance Semigroup RefCount where RefCount x <> RefCount y = RefCount (x + y) + +data HeldEbHashSet = HeldEbHashSet !(Map EbHash RefCount) !(Map Election Refs) + deriving (Eq, Show) + +empty :: HeldEbHashSet +empty = HeldEbHashSet Map.empty Map.empty + +insert :: EbHash -> Election -> HeldEbHashSet -> HeldEbHashSet +insert eh el (HeldEbHashSet ehs els) = + HeldEbHashSet + (Map.insertWith (<>) eh (RefCount 1) ehs) + (Map.alter + (\case + Nothing -> Just $! Ref1 eh + Just (Ref1 old) -> Just $! Ref2 old eh + Just Ref2{} -> error "HeldEbHashSet.insert: third insert for one election" + ) + el + els + ) + +member :: EbHash -> HeldEbHashSet -> Bool +member eh (HeldEbHashSet ehs _els) = Map.member eh ehs + +prune :: (Election -> Bool) -> HeldEbHashSet -> HeldEbHashSet +prune p (HeldEbHashSet ehs els) = + HeldEbHashSet + (foldl' decr ehs (concatMap refsEbs (Map.elems dropped))) + kept + where + (dropped, kept) = Map.partitionWithKey (\el _ -> p el) els + decr m eh = Map.update step eh m + step (RefCount n) | n <= 1 = Nothing + | otherwise = Just $! RefCount (n - 1) + refsEbs (Ref1 a) = [a] + refsEbs (Ref2 a b) = [a, b] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index db71bc26c7..414508c270 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -3,6 +3,8 @@ module RefModel (module RefModel) where import EbHashMap (EbHash (..), Election (..), electionSlot, Slot (..)) import EbHashMap (EbHashMap) import qualified EbHashMap as EM +import HeldEbHashSet (HeldEbHashSet) +import qualified HeldEbHashSet as Held import Data.Foldable (foldl', toList) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) @@ -176,22 +178,22 @@ data PeerOfferings = PeerOfferings !(EbHashMap (Maybe LeiosNotifySide, Any)) !(E deriving (Eq, Show) data St = St - { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements + { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: !(Peer :-> PeerOfferings) -- §2 LstPeerOfferings - , stPeerOfferGates :: !(Peer :-> EbHashMap (Maybe OfferLevel)) -- §2 LstPeerOfferGates (payload: offer level sent so far) - , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) - , stWanted :: !(EbHashMap WantState) -- §2 LstWanted - , stVolatileBody :: !(EbHashMap ()) -- §2 LstVolatileBody - , stVolatileClosure :: !(EbHashMap ()) -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) - , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified - , stPeerInflight :: !(Peer :-> MiniProtocol :-> Seq Req) -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) - , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent + , stPeerOfferings :: !(Peer :-> PeerOfferings) -- §2 LstPeerOfferings + , stPeerOfferGates :: !(Peer :-> EbHashMap (Maybe OfferLevel)) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) + , stWanted :: !(EbHashMap WantState) -- §2 LstWanted + , stVolatileBody :: !HeldEbHashSet -- §2 LstVolatileBody + , stVolatileClosure :: !HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified + , stPeerInflight :: !(Peer :-> MiniProtocol :-> Seq Req) -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) + , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent } deriving (Eq, Show) emptySt :: St -- BEH-Startup -emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty EM.empty EM.empty EM.empty Map.empty Map.empty Map.empty +emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty EM.empty Held.empty Held.empty Map.empty Map.empty Map.empty emptyPeerOfferings :: PeerOfferings -- §2 LstPeerOfferings emptyPeerOfferings = PeerOfferings EM.empty Map.empty @@ -741,9 +743,8 @@ hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of let st1 = popFront peer FetchBody st in if not (validBody env eh bs cs body) then pure (st1, [Disconnect peer BodyMismatch]) - else if not (activelyWantsEh st eh) - then considerFetchAfter env now st1 [] - else do + else case wantStateOf st eh of + Just (AwaitingBody _ _) -> do let txrefs = bodyTxlist body txhs = Set.fromList (map txRefHash txrefs) hits <- txCacheOnBody (ifTxc ifs) eh txhs @@ -757,6 +758,7 @@ hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of : [ SubmitDisk (Write (WriteClosure eh copied)) | not (null copied) ] st2 = setTxs eh jobsMap (fromIntegral (length writes)) st1 considerFetchAfter env now st2 writes + _ -> considerFetchAfter env now st1 [] _ -> pure (st, [Disconnect peer UnsolicitedResponse]) hBlockTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> [Tx] -> St -> m (St, [Effect]) -- BEH-Responses · §3 LevBlockTxs @@ -793,14 +795,16 @@ hServeTxs ifs _env _now peer eh txs st = do else pure (st, [Disconnect peer RequestedAbsentData]) hCertValidated :: Monad m => Ifaces m -> Env -> Time -> AnnouncementTriple -> ByteCount -> ByteCount -> St -> m (St, [Effect]) -- BEH-Wanting · BEH-FetchPriority · §3 LevCertValidated -hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st = do - txCacheEvictForValidCert (ifTxc ifs) el eh - let st1 = setCertified el (hh, eh) st - done <- isComplete ifs eh - let (st2, fx) | belowTip env el = (st1, []) - | done = recordCompleteCert env el eh st1 - | otherwise = (supersedeWant el eh bs cs st1, []) - considerFetchAfter env now st2 fx +hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st + | Map.member el (stCertified st) = pure (st, []) + | otherwise = do + txCacheEvictForValidCert (ifTxc ifs) el eh + let st1 = setCertified el (hh, eh) st + done <- isComplete ifs eh + let (st2, fx) | belowTip env el = (st1, []) + | done = recordCompleteCert env el eh st1 + | otherwise = (supersedeWant el eh bs cs st1, []) + considerFetchAfter env now st2 fx hPeerAdd :: Monad m => Env -> Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd (prime the notify client: envNotifyMaxCapacity RequestNext) hPeerAdd env peer cls st = pure @@ -970,18 +974,18 @@ enqueueBodyOffers eh = enqueueToAll (NotifyBlockOffer eh) enqueueClosureOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) enqueueClosureOffers eh = enqueueToAll (NotifyBlockTxsOffer eh) -addVolatile :: EbHash -> [Election] -> EbHashMap () -> EbHashMap () -- §2 LstVolatileBody/LstVolatileClosure -addVolatile eh els m = foldl' (\acc el -> EM.upsert eh el () acc) m els +addVolatile :: EbHash -> [Election] -> HeldEbHashSet -> HeldEbHashSet -- §2 LstVolatileBody/LstVolatileClosure +addVolatile eh els m = foldl' (\acc el -> Held.insert eh el acc) m els -heldIn :: EbHash -> EbHashMap a -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership -heldIn eh m = isJust (EM.lookupEb eh m) +heldIn :: EbHash -> HeldEbHashSet -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership +heldIn = Held.member pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete pruneBelow s st = st { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) , stWanted = EM.pruneElections (\el -> electionSlot el < s) (stWanted st) - , stVolatileBody = EM.pruneElections (\el -> electionSlot el < s) (stVolatileBody st) - , stVolatileClosure = EM.pruneElections (\el -> electionSlot el < s) (stVolatileClosure st) + , stVolatileBody = Held.prune (\el -> electionSlot el < s) (stVolatileBody st) + , stVolatileClosure = Held.prune (\el -> electionSlot el < s) (stVolatileClosure st) , stCertified = pruneElectionMap s (stCertified st) , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) , stPeerOfferings = Map.map (\(PeerOfferings m c) -> PeerOfferings (EM.pruneElections (\el -> electionSlot el < s) m) (pruneElectionMap s c)) (stPeerOfferings st) @@ -1019,7 +1023,6 @@ centralAnnounce ifs env _now h st = case rbAnnounce h of let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } nowAvailable = heldIn eh (stVolatileClosure st1) && not (belowTip env el) - && (EM.activeRef <$> EM.lookupElection el (stVolatileClosure st1)) /= Just eh st2 = anchorVolatile el eh st1 st3 | belowTip env el = st2 | heldIn eh (stVolatileClosure st2) = st2 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 002a790388..6da9412c5a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -120,6 +120,15 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "a body response is not blocked behind an in-flight txs request" (not (any isDisconnect fx)) assertBool "eh100 advanced to AwaitingTxs" (case wantStateOf st (EbHash 100) of Just AwaitingTxs{} -> True; _ -> False) + , testCase "BEH-Responses: a second body for an already-fetched EB is ignored (no double write)" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) StakeSampled + , ann (Peer 1) hdr100, ann (Peer 2) hdr100 + , offer (Peer 1) (EbHash 100), offer (Peer 2) (EbHash 100) + , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) + , LevWiredMsg (Peer 2) (MsgLeiosBlock (EbHash 100) body100) ] + bodyWrites = length [ () | SubmitDisk (Write (WriteBody _)) <- fx ] + bodyWrites @?= 1 + , testCase "Job: jobBytes is the real summed tx size" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100) ] @@ -276,6 +285,12 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "fans NotifyVotingAndChainSel for the (re)certified EB" (NotifyVotingAndChainSel (EbHash 100) [] `elem` fx) + , testCase "BEH-Wanting: a duplicate LevCertValidated is idempotent (no crash)" $ do + let at = AnnouncementTriple el100 (HeaderHash 10) (EbHash 100) + (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevCertValidated at 200 300, LevCertValidated at 200 300 ] + isCertifiedEb st el100 (EbHash 100) @?= True + , testCase "BEH-Completion: announcing an already-available closure under a new election fans voting + ChainSel" $ do let ifs = nullIfaces { ifDb = (ifDb nullIfaces) { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) From 6424939f28cf440470ffc0a71657fcdd58c784b2 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 15:35:07 -0400 Subject: [PATCH 11/16] WIP MsgLeiosBlockTxsRequest is now bitfield --- .../Test/Leios/RefModel/RefModel.hs | 70 ++++++++++--------- .../Test/Leios/RefModel/test/RefModelTest.hs | 8 ++- 2 files changed, 43 insertions(+), 35 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 414508c270..f4932d6875 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -102,11 +102,14 @@ instance Semigroup LeiosNotifySide where -- §2 LstPeerOfferings (tupl data ChainSyncSide = ChainSyncSide HeaderHash -- §2 LstPeerOfferings / ChainSyncSide deriving (Eq, Show) -data Job = Job (NonEmpty TxHash) ByteCount -- §2 Job (ordered txs + byte size) +data Job = Job (NonEmpty (Word16, TxHash)) ByteCount -- §2 Job (body positions + tx hashes + byte size) deriving (Eq, Ord, Show) jobTxs :: Job -> NonEmpty TxHash -jobTxs (Job txs _) = txs +jobTxs (Job pts _) = fmap snd pts + +jobPositions :: Job -> NonEmpty Word16 +jobPositions (Job pts _) = fmap fst pts jobByteSize :: Job -> ByteCount jobByteSize (Job _ n) = n @@ -174,21 +177,24 @@ data Notification -- §2 LstPeerNotifyQueue infixr 1 :-> type k :-> v = Map k v -data PeerOfferings = PeerOfferings !(EbHashMap (Maybe LeiosNotifySide, Any)) !(Election :-> ChainSyncSide) -- §2 LstPeerOfferings (offer levels; per-election ChainSync header hashes) +data PeerOfferings = -- §2 LstPeerOfferings (offer levels; per-election ChainSync header hashes) + PeerOfferings + (EbHashMap (Maybe LeiosNotifySide, Any)) + (Election :-> ChainSyncSide) deriving (Eq, Show) data St = St - { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements - , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: !(Peer :-> PeerOfferings) -- §2 LstPeerOfferings - , stPeerOfferGates :: !(Peer :-> EbHashMap (Maybe OfferLevel)) -- §2 LstPeerOfferGates (payload: offer level sent so far) - , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) - , stWanted :: !(EbHashMap WantState) -- §2 LstWanted - , stVolatileBody :: !HeldEbHashSet -- §2 LstVolatileBody - , stVolatileClosure :: !HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) - , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified - , stPeerInflight :: !(Peer :-> MiniProtocol :-> Seq Req) -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) - , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent + { stFirstAnnouncements :: Election :-> AnnState -- §2 LstFirstAnnouncements + , stPeerFirstAnnouncements :: Peer :-> Election :-> AnnSeen -- §2 LstPeerFirstAnnouncements + , stPeerOfferings :: Peer :-> PeerOfferings -- §2 LstPeerOfferings + , stPeerOfferGates :: Peer :-> EbHashMap (Maybe OfferLevel) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerNotifyQueue :: Peer :-> (Seq Notification, Int) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) + , stWanted :: EbHashMap WantState -- §2 LstWanted + , stVolatileBody :: HeldEbHashSet -- §2 LstVolatileBody + , stVolatileClosure :: HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stCertified :: Election :-> (HeaderHash, EbHash) -- §2 LstCertified + , stPeerInflight :: Peer :-> MiniProtocol :-> Seq Req -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) + , stPeerPresent :: Peer :-> PeerInfo -- §2 LstPeerPresent } deriving (Eq, Show) @@ -237,7 +243,7 @@ data DbKey = DbBody EbHash | DbClosureTx EbHash TxHash -- §2 dbQueryPresent ke data LeiosDb m = LeiosDb -- §2 disk store interface { dbQueryPresent :: Set DbKey -> m (Set DbKey) -- BEH-Completion / BEH-FetchServe , dbReadBody :: EbHash -> m (Maybe Body) -- BEH-Completion - , dbReadClosureTxs :: EbHash -> [TxHash] -> m [Tx] -- BEH-FetchServe + , dbReadClosureTxs :: EbHash -> NonEmpty Word16 -> m [Tx] -- BEH-FetchServe (txs at the requested body positions) } data TxCache m = TxCache -- §7 TxCache hooks @@ -260,7 +266,7 @@ data WireMsg -- §2 Wire messages | MsgLeiosBlockTxsOffer Slot EbHash | MsgLeiosBlockRequest EbHash | MsgLeiosBlock EbHash Body - | MsgLeiosBlockTxsRequest EbHash (NonEmpty TxHash) + | MsgLeiosBlockTxsRequest EbHash (NonEmpty Word16) | MsgLeiosBlockTxs EbHash [Tx] deriving (Eq, Show) @@ -477,19 +483,19 @@ takeWhileBudget budget ((b, r) : rest) | b <= budget = r : takeWhileBudget (budget - b) rest | otherwise = [] -chunk :: Env -> [TxRef] -> Map JobId Job -- BEH-ChunkJobs · §2 Job (≈ jobSize batches) +chunk :: Env -> [(Word16, TxRef)] -> Map JobId Job -- BEH-ChunkJobs · §2 Job (≈ jobSize batches) chunk env trs = - Map.fromList (zip (map JobId [0 ..]) (map mkJob (batchBySize (envJobSize env) trs))) - where mkJob batch = Job (NE.fromList (map txRefHash batch)) (sum (map txRefSize batch)) + Map.fromList (zip (map JobId [0 ..]) (map mkJob (batchBySize (txRefSize . snd) (envJobSize env) trs))) + where mkJob batch = Job (NE.fromList (map (fmap txRefHash) batch)) (sum (map (txRefSize . snd) batch)) -batchBySize :: ByteCount -> [TxRef] -> [[TxRef]] -- §2 jobSize -batchBySize _ [] = [] -batchBySize limit (x : xs) = go [x] (txRefSize x) xs +batchBySize :: (a -> ByteCount) -> ByteCount -> [a] -> [[a]] -- §2 jobSize +batchBySize _ _ [] = [] +batchBySize size limit (x : xs) = go [x] (size x) xs where go acc _ [] = [reverse acc] go acc sz (t : ts) - | sz + txRefSize t > limit && not (null acc) = reverse acc : go [t] (txRefSize t) ts - | otherwise = go (t : acc) (sz + txRefSize t) ts + | sz + size t > limit && not (null acc) = reverse acc : go [t] (size t) ts + | otherwise = go (t : acc) (sz + size t) ts hashes :: [Tx] -> Set TxHash hashes = Set.fromList . map txHash @@ -531,7 +537,7 @@ stepWired ifs env now peer msg st = case notifyMsgSlot st peer msg of MsgLeiosBlockTxsOffer sl eh -> hOffer env now peer sl eh OfferBodyAndClosure st MsgLeiosBlockRequest eh -> hServeBody ifs env now peer eh st MsgLeiosBlock eh body -> hBlock ifs env now peer eh body st - MsgLeiosBlockTxsRequest eh txs -> hServeTxs ifs env now peer eh txs st + MsgLeiosBlockTxsRequest eh poss -> hServeTxs ifs env now peer eh poss st MsgLeiosBlockTxs eh txs -> hBlockTxs ifs env now peer eh txs st hAnnouncement :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockAnnouncement @@ -751,7 +757,7 @@ hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of memHs <- mempoolQueryPresent (ifMem ifs) (txhs `Set.difference` hashes hits) txCacheOnAcquire (ifTxc ifs) memHs let onHand = hashes hits `Set.union` hashes memHs - toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] + toFetch = [ (i, tr) | (i, tr) <- zip [0 :: Word16 ..] (toList txrefs), not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = hits ++ memHs writes = SubmitDisk (Write (WriteBody body)) @@ -787,10 +793,10 @@ hServeBody ifs _env _now peer eh st = do Just body -> pure (st, [Send peer (MsgLeiosBlock eh body)]) _ -> pure (st, [Disconnect peer RequestedAbsentData]) -hServeTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> NonEmpty TxHash -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockTxsRequest -hServeTxs ifs _env _now peer eh txs st = do - served <- dbReadClosureTxs (ifDb ifs) eh (NE.toList txs) - if length served == NE.length txs +hServeTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> NonEmpty Word16 -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockTxsRequest +hServeTxs ifs _env _now peer eh poss st = do + served <- dbReadClosureTxs (ifDb ifs) eh poss + if length served == NE.length poss then pure (st, [Send peer (MsgLeiosBlockTxs eh served)]) else pure (st, [Disconnect peer RequestedAbsentData]) @@ -893,7 +899,7 @@ hSelfIssued ifs env now h body st = case rbAnnounce h of memHs <- mempoolQueryPresent (ifMem ifs) txhs txCacheOnAcquire (ifTxc ifs) memHs let onHand = hashes memHs - toFetch = [ tr | tr <- toList txrefs, not (txRefHash tr `Set.member` onHand) ] + toFetch = [ (i, tr) | (i, tr) <- zip [0 :: Word16 ..] (toList txrefs), not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = memHs writes = SubmitDisk (Write (WriteBody body)) @@ -929,7 +935,7 @@ armTimer env (Time now) peer = SetTimer peer (Time (now + envRequestTimeout env) reqWire :: St -> Req -> WireMsg reqWire _ (ReqBody eh _ _) = MsgLeiosBlockRequest eh -reqWire _ (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobTxs job) +reqWire _ (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobPositions job) frontReq :: St -> Peer -> MiniProtocol -> Maybe Req frontReq st peer mp = case inflightFifo st peer mp of diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 6da9412c5a..a0a992dc3a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -64,7 +64,9 @@ servingIfaces :: Ifaces Identity servingIfaces = nullIfaces { ifDb = (ifDb nullIfaces) { dbQueryPresent = pure - , dbReadClosureTxs = \_ hs -> pure [ Tx h 1 | h <- hs ] } } + , dbReadClosureTxs = \_ poss -> + let txrefs = Map.fromList (zip [0 ..] (bodyTxlist body100)) + in pure [ Tx (txRefHash tr) 1 | i <- NE.toList poss, Just tr <- [Map.lookup i txrefs] ] } } isReq :: Effect -> Bool @@ -105,7 +107,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-ChunkJobs + BEH-ClosureFetch: body then closure-offer requests the chunked job's txs" $ do let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100, offer (Peer 1) (EbHash 100) , LevWiredMsg (Peer 1) (MsgLeiosBlock (EbHash 100) body100), txsOffer (Peer 1) (EbHash 100) ] - [ txs | Send _ (MsgLeiosBlockTxsRequest _ txs) <- fx ] @?= [NE.fromList [TxHash 1, TxHash 2]] + [ poss | Send _ (MsgLeiosBlockTxsRequest _ poss) <- fx ] @?= [NE.fromList [0, 1]] assertBool "want advanced to AwaitingTxs" (case wantStateOf st (EbHash 100) of Just AwaitingTxs{} -> True; _ -> False) @@ -273,7 +275,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-FetchServe: a tx request is served with the requested txs in order" $ do let (_, fx) = runWith servingIfaces [ LevPeerAdd (Peer 2) PeerSharingSampled - , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [TxHash 1, TxHash 2])) ] + , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [0, 1])) ] [ ts | Send _ (MsgLeiosBlockTxs _ ts) <- fx ] @?= [[Tx (TxHash 1) 1, Tx (TxHash 2) 1]] , testCase "BEH-Completion: a cert for an already-complete EB still fans voting + ChainSel" $ do From 7d07ad5c4b51ee713c0fa12634b5dba6e51bb02e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 17:07:41 -0400 Subject: [PATCH 12/16] WIP stVolatile* is now accurate on restart --- .../Test/Leios/RefModel/HeldEbHashSet.hs | 50 ++++++-------- .../Test/Leios/RefModel/RefModel.hs | 67 +++++++++++-------- .../Test/Leios/RefModel/test/RefModelTest.hs | 51 ++++++++++++-- 3 files changed, 104 insertions(+), 64 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs index ef4ed5d20f..8b0c057b6e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/HeldEbHashSet.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module HeldEbHashSet ( HeldEbHashSet , empty @@ -8,15 +6,13 @@ module HeldEbHashSet ( , prune ) where -import Data.List (foldl') +import Data.Foldable (foldl', toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import Data.Word (Word16) -import EbHashMap (EbHash, Election) - --- | One or two, but no meaningful order -data Refs = Ref1 !EbHash | Ref2 !EbHash !EbHash - deriving (Eq, Show) +import EbHashMap (EbHash, Slot) newtype RefCount = -- | INVARIANT positive @@ -25,38 +21,34 @@ newtype RefCount = instance Semigroup RefCount where RefCount x <> RefCount y = RefCount (x + y) -data HeldEbHashSet = HeldEbHashSet !(Map EbHash RefCount) !(Map Election Refs) +data HeldEbHashSet = + HeldEbHashSet + !(Map EbHash RefCount) + !(Map Slot (NESet EbHash)) deriving (Eq, Show) empty :: HeldEbHashSet empty = HeldEbHashSet Map.empty Map.empty -insert :: EbHash -> Election -> HeldEbHashSet -> HeldEbHashSet -insert eh el (HeldEbHashSet ehs els) = - HeldEbHashSet - (Map.insertWith (<>) eh (RefCount 1) ehs) - (Map.alter - (\case - Nothing -> Just $! Ref1 eh - Just (Ref1 old) -> Just $! Ref2 old eh - Just Ref2{} -> error "HeldEbHashSet.insert: third insert for one election" - ) - el - els - ) +-- | Under normal operation this is called at most twice for one slot: the first-announced EB and the certified EB. Because we reconstruct this structure on startup without the central state that deduplicates announcements/certs, a slot battle or a (bounded) sequence of restarts can drive it higher; we accept that laxity, so 'insert' never fails. +insert :: EbHash -> Slot -> HeldEbHashSet -> HeldEbHashSet +insert eh slot (HeldEbHashSet ms els) = + HeldEbHashSet ms' els' + where + already = maybe False (NESet.member eh) (Map.lookup slot els) + ms' = if already then ms else Map.insertWith (<>) eh (RefCount 1) ms + els' = Map.insertWith NESet.union slot (NESet.singleton eh) els member :: EbHash -> HeldEbHashSet -> Bool -member eh (HeldEbHashSet ehs _els) = Map.member eh ehs +member eh (HeldEbHashSet ms _els) = Map.member eh ms -prune :: (Election -> Bool) -> HeldEbHashSet -> HeldEbHashSet -prune p (HeldEbHashSet ehs els) = +prune :: (Slot -> Bool) -> HeldEbHashSet -> HeldEbHashSet +prune p (HeldEbHashSet ms els) = HeldEbHashSet - (foldl' decr ehs (concatMap refsEbs (Map.elems dropped))) + (foldl' decr ms (concatMap toList (Map.elems dropped))) kept where - (dropped, kept) = Map.partitionWithKey (\el _ -> p el) els + (dropped, kept) = Map.partitionWithKey (\slot _ -> p slot) els decr m eh = Map.update step eh m step (RefCount n) | n <= 1 = Nothing | otherwise = Just $! RefCount (n - 1) - refsEbs (Ref1 a) = [a] - refsEbs (Ref2 a b) = [a, b] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index f4932d6875..180c2ca2e7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -1,5 +1,6 @@ module RefModel (module RefModel) where +import Control.Monad (foldM) import EbHashMap (EbHash (..), Election (..), electionSlot, Slot (..)) import EbHashMap (EbHashMap) import qualified EbHashMap as EM @@ -190,8 +191,8 @@ data St = St , stPeerOfferGates :: Peer :-> EbHashMap (Maybe OfferLevel) -- §2 LstPeerOfferGates (payload: offer level sent so far) , stPeerNotifyQueue :: Peer :-> (Seq Notification, Int) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) , stWanted :: EbHashMap WantState -- §2 LstWanted - , stVolatileBody :: HeldEbHashSet -- §2 LstVolatileBody - , stVolatileClosure :: HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stVolatileBody :: HeldEbHashSet -- §2 LstVolatileBody + , stVolatileClosure :: HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) , stCertified :: Election :-> (HeaderHash, EbHash) -- §2 LstCertified , stPeerInflight :: Peer :-> MiniProtocol :-> Seq Req -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) , stPeerPresent :: Peer :-> PeerInfo -- §2 LstPeerPresent @@ -201,6 +202,21 @@ data St = St emptySt :: St -- BEH-Startup emptySt = St Map.empty Map.empty Map.empty Map.empty Map.empty EM.empty Held.empty Held.empty Map.empty Map.empty Map.empty +initSt :: Monad m => LeiosDb m -> m St -- BEH-Startup: rebuild stVolatile* from persisted references (the other central state is not reconstructed) +initSt db = foldM loadRef emptySt =<< dbReadAllRefs db + where + loadRef st (slot, eh) = do + mb <- dbReadBody db eh + case mb of + Nothing -> pure st + Just body -> do + let keys = Set.fromList (map (DbClosureTx eh . txRefHash) (bodyTxlist body)) + have <- dbQueryPresent db keys + let st1 = st { stVolatileBody = Held.insert eh slot (stVolatileBody st) } + pure $ if keys `Set.isSubsetOf` have + then st1 { stVolatileClosure = Held.insert eh slot (stVolatileClosure st1) } + else st1 + emptyPeerOfferings :: PeerOfferings -- §2 LstPeerOfferings emptyPeerOfferings = PeerOfferings EM.empty Map.empty @@ -244,6 +260,7 @@ data LeiosDb m = LeiosDb -- §2 disk store interface { dbQueryPresent :: Set DbKey -> m (Set DbKey) -- BEH-Completion / BEH-FetchServe , dbReadBody :: EbHash -> m (Maybe Body) -- BEH-Completion , dbReadClosureTxs :: EbHash -> NonEmpty Word16 -> m [Tx] -- BEH-FetchServe (txs at the requested body positions) + , dbReadAllRefs :: m [(Slot, EbHash)] -- BEH-Startup (first-announced/certified references; reconstruct stVolatile*) } data TxCache m = TxCache -- §7 TxCache hooks @@ -294,6 +311,7 @@ data DiskOp -- §2 disk store interface = Write DiskWrite | GarbageCollect Slot | Promote Slot + | RecordRef Slot EbHash -- BEH-Startup: persist a first-announced/certified reference (fire-and-forget, no LevDiskDone; pruned by GarbageCollect, ignored by Promote) deriving (Eq, Show) data Offence -- §3 disconnect reasons (carried by Disconnect) @@ -497,8 +515,8 @@ batchBySize size limit (x : xs) = go [x] (size x) xs | sz + size t > limit && not (null acc) = reverse acc : go [t] (size t) ts | otherwise = go (t : acc) (sz + size t) ts -hashes :: [Tx] -> Set TxHash -hashes = Set.fromList . map txHash +txHashes :: [Tx] -> Set TxHash +txHashes = Set.fromList . map txHash ----- @@ -754,9 +772,9 @@ hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of let txrefs = bodyTxlist body txhs = Set.fromList (map txRefHash txrefs) hits <- txCacheOnBody (ifTxc ifs) eh txhs - memHs <- mempoolQueryPresent (ifMem ifs) (txhs `Set.difference` hashes hits) + memHs <- mempoolQueryPresent (ifMem ifs) (txhs `Set.difference` txHashes hits) txCacheOnAcquire (ifTxc ifs) memHs - let onHand = hashes hits `Set.union` hashes memHs + let onHand = txHashes hits `Set.union` txHashes memHs toFetch = [ (i, tr) | (i, tr) <- zip [0 :: Word16 ..] (toList txrefs), not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = hits ++ memHs @@ -806,11 +824,10 @@ hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st | otherwise = do txCacheEvictForValidCert (ifTxc ifs) el eh let st1 = setCertified el (hh, eh) st - done <- isComplete ifs eh - let (st2, fx) | belowTip env el = (st1, []) - | done = recordCompleteCert env el eh st1 - | otherwise = (supersedeWant el eh bs cs st1, []) - considerFetchAfter env now st2 fx + (st2, fx) | belowTip env el = (st1, []) + | heldIn eh (stVolatileClosure st1) = recordCompleteCert env el eh st1 + | otherwise = (anchorVolatile el eh (supersedeWant el eh bs cs st1), []) + considerFetchAfter env now st2 (SubmitDisk (RecordRef (electionSlot el) eh) : fx) hPeerAdd :: Monad m => Env -> Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd (prime the notify client: envNotifyMaxCapacity RequestNext) hPeerAdd env peer cls st = pure @@ -846,7 +863,7 @@ hDiskDone _ifs env _now w st = case w of in pure (st2, fx1 ++ fx2) WriteClosure eh _ -> pure (decWrite env eh st) -decWrite :: Env -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone persist-before-expose (one DiskWrite finished) +decWrite :: Env -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone decWrite env eh st = case wantStateOf st eh of Just (AwaitingTxs t) -> case decTxsState t of Just t' -> (updateWant eh (\_ -> Just (AwaitingTxs t')) st, []) @@ -898,7 +915,7 @@ hSelfIssued ifs env now h body st = case rbAnnounce h of txhs = Set.fromList (map txRefHash txrefs) memHs <- mempoolQueryPresent (ifMem ifs) txhs txCacheOnAcquire (ifTxc ifs) memHs - let onHand = hashes memHs + let onHand = txHashes memHs toFetch = [ (i, tr) | (i, tr) <- zip [0 :: Word16 ..] (toList txrefs), not (txRefHash tr `Set.member` onHand) ] jobsMap = chunk env toFetch copied = memHs @@ -961,16 +978,6 @@ removeWantEl el st = st { stWanted = EM.deleteElection el (stWanted st) } removeWantEb :: EbHash -> St -> St -- §2 LstWanted (drop every election actively wanting eh) removeWantEb eh st = st { stWanted = foldl' (flip EM.deleteElection) (stWanted st) (electionsNaming eh st) } -isComplete :: Monad m => Ifaces m -> EbHash -> m Bool -- BEH-Completion (restart-time check only, in LevCertValidated) -isComplete ifs eh = do - mb <- dbReadBody (ifDb ifs) eh - case mb of - Nothing -> pure False - Just body -> do - let need = Set.insert (DbBody eh) (Set.fromList (map (DbClosureTx eh . txRefHash) (bodyTxlist body))) - have <- dbQueryPresent (ifDb ifs) need - pure (need `Set.isSubsetOf` have) - setCertified :: Election -> (HeaderHash, EbHash) -> St -> St setCertified el v st = st { stCertified = Map.insert el v (stCertified st) } @@ -981,7 +988,7 @@ enqueueClosureOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BE enqueueClosureOffers eh = enqueueToAll (NotifyBlockTxsOffer eh) addVolatile :: EbHash -> [Election] -> HeldEbHashSet -> HeldEbHashSet -- §2 LstVolatileBody/LstVolatileClosure -addVolatile eh els m = foldl' (\acc el -> Held.insert eh el acc) m els +addVolatile eh els m = foldl' (\acc el -> Held.insert eh (electionSlot el) acc) m els heldIn :: EbHash -> HeldEbHashSet -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership heldIn = Held.member @@ -990,8 +997,8 @@ pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-de pruneBelow s st = st { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) , stWanted = EM.pruneElections (\el -> electionSlot el < s) (stWanted st) - , stVolatileBody = Held.prune (\el -> electionSlot el < s) (stVolatileBody st) - , stVolatileClosure = Held.prune (\el -> electionSlot el < s) (stVolatileClosure st) + , stVolatileBody = Held.prune (< s) (stVolatileBody st) + , stVolatileClosure = Held.prune (< s) (stVolatileClosure st) , stCertified = pruneElectionMap s (stCertified st) , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) , stPeerOfferings = Map.map (\(PeerOfferings m c) -> PeerOfferings (EM.pruneElections (\el -> electionSlot el < s) m) (pruneElectionMap s c)) (stPeerOfferings st) @@ -1014,7 +1021,7 @@ advancePeerAnn peer el h st = putSeen seen = st { stPeerFirstAnnouncements = Map.insert peer - (Map.insert el seen (fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)))) + (Map.insert el seen perPeer) (stPeerFirstAnnouncements st) } centralAnnounce :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> St -> m (St, [Effect]) -- §3 LevBlockAnnouncement central branch @@ -1035,7 +1042,8 @@ centralAnnounce ifs env _now h st = case rbAnnounce h of | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 (st5, fx') = enqueueHeldOffers eh st4 - pure (st5, fx ++ fx' ++ [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st1) | nowAvailable ]) + pure (st5, fx ++ fx' ++ [ SubmitDisk (RecordRef (electionSlot el) eh) ] + ++ [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st1) | nowAvailable ]) Just (AnnOne h1) | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) | otherwise -> @@ -1073,7 +1081,8 @@ nullIfaces :: Applicative m => Ifaces m nullIfaces = Ifaces { ifDb = LeiosDb { dbQueryPresent = const (pure Set.empty) , dbReadBody = const (pure Nothing) - , dbReadClosureTxs = \_ _ -> pure [] } + , dbReadClosureTxs = \_ _ -> pure [] + , dbReadAllRefs = pure [] } , ifTxc = TxCache { txCacheNoteAnnouncement = \_ _ -> pure () , txCacheEvictForValidCert = \_ _ -> pure () , txCacheOnBody = \_ _ -> pure [] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index a0a992dc3a..9346c4d2d3 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -56,6 +56,10 @@ runWith ifs = foldl' go (emptySt, []) run :: [Stimulus] -> (St, [Effect]) run = runWith nullIfaces +runFrom :: St -> Ifaces Identity -> [Stimulus] -> (St, [Effect]) +runFrom st0 ifs = foldl' go (st0, []) + where go (st, fx) s = let (st', fx') = runIdentity (step ifs env (Time 0) s st) in (st', fx ++ fx') + foldEnv :: Env -> [Stimulus] -> (St, [Effect]) foldEnv e = foldl' go (emptySt, []) where go (st, fx) s = let (st', fx') = runIdentity (step nullIfaces e (Time 0) s st) in (st', fx ++ fx') @@ -278,12 +282,14 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , LevWiredMsg (Peer 2) (MsgLeiosBlockTxsRequest (EbHash 100) (NE.fromList [0, 1])) ] [ ts | Send _ (MsgLeiosBlockTxs _ ts) <- fx ] @?= [[Tx (TxHash 1) 1, Tx (TxHash 2) 1]] - , testCase "BEH-Completion: a cert for an already-complete EB still fans voting + ChainSel" $ do + , testCase "BEH-Completion: a cert for an EB reconstructed as complete on startup still fans voting + ChainSel" $ do let ifs = nullIfaces { ifDb = (ifDb nullIfaces) { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) - , dbQueryPresent = pure } } + , dbQueryPresent = pure + , dbReadAllRefs = pure [(Slot 7, EbHash 100)] } } el2 = Election (Slot 7) (PoolId 2) - (_, fx) = runWith ifs [ LevCertValidated (AnnouncementTriple el2 (HeaderHash 99) (EbHash 100)) 200 300 ] + st0 = runIdentity (initSt (ifDb ifs)) + (_, fx) = runFrom st0 ifs [ LevCertValidated (AnnouncementTriple el2 (HeaderHash 99) (EbHash 100)) 200 300 ] assertBool "fans NotifyVotingAndChainSel for the (re)certified EB" (NotifyVotingAndChainSel (EbHash 100) [] `elem` fx) @@ -296,15 +302,48 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , testCase "BEH-Completion: announcing an already-available closure under a new election fans voting + ChainSel" $ do let ifs = nullIfaces { ifDb = (ifDb nullIfaces) { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) - , dbQueryPresent = pure } } + , dbQueryPresent = pure + , dbReadAllRefs = pure [(Slot 7, EbHash 100)] } } e2 = Election (Slot 7) (PoolId 2) e3 = Election (Slot 8) (PoolId 3) hdrE3 = RbHeader (HeaderHash 78) e3 (Just (EbAnn (EbHash 100) 200 300)) False True - (_, fx) = runWith ifs [ LevCertValidated (AnnouncementTriple e2 (HeaderHash 99) (EbHash 100)) 200 300 - , LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdrE3 ] + st0 = runIdentity (initSt (ifDb ifs)) + (_, fx) = runFrom st0 ifs [ LevCertValidated (AnnouncementTriple e2 (HeaderHash 99) (EbHash 100)) 200 300 + , LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdrE3 ] assertBool "fans NotifyVotingAndChainSel carrying the new announcing RB's HeaderHash" (NotifyVotingAndChainSel (EbHash 100) [HeaderHash 78] `elem` fx) + , testCase "BEH-Startup: a first announcement and a cert each persist a (slot, EbHash) reference" $ do + let (_, fxAnn) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 ] + (_, fxCert) = run [ LevCertValidated (AnnouncementTriple el100 (HeaderHash 10) (EbHash 100)) 200 300 ] + ref = SubmitDisk (RecordRef (electionSlot el100) (EbHash 100)) + assertBool "first announcement records a ref" (ref `elem` fxAnn) + assertBool "cert records a ref" (ref `elem` fxCert) + + , testCase "BEH-Startup: initSt reconstructs the body, and the closure only when all txs are present" $ do + let mkDb present = (ifDb nullIfaces) + { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) + , dbQueryPresent = present + , dbReadAllRefs = pure [(Slot 7, EbHash 100)] } + stComplete = runIdentity (initSt (mkDb pure)) + stBodyOnly = runIdentity (initSt (mkDb (const (pure mempty)))) + heldIn (EbHash 100) (stVolatileBody stComplete) @?= True + heldIn (EbHash 100) (stVolatileClosure stComplete) @?= True + heldIn (EbHash 100) (stVolatileBody stBodyOnly) @?= True + heldIn (EbHash 100) (stVolatileClosure stBodyOnly) @?= False + + , testCase "BEH-Startup: a cert anchors an already-held body to its own slot (survives GC of the announcing slot)" $ do + let ifs = nullIfaces { ifDb = (ifDb nullIfaces) + { dbReadBody = \e -> pure (if e == EbHash 100 then Just body100 else Nothing) + , dbQueryPresent = const (pure mempty) -- body present, closure incomplete + , dbReadAllRefs = pure [(Slot 5, EbHash 100)] } } -- body anchored under slot 5 + eNew = Election (Slot 10) (PoolId 2) + st0 = runIdentity (initSt (ifDb ifs)) + (st1, _) = runFrom st0 ifs [ LevCertValidated (AnnouncementTriple eNew (HeaderHash 99) (EbHash 100)) 200 300 ] + heldIn (EbHash 100) (stVolatileBody st1) @?= True + assertBool "the cert's slot keeps the body held after the announcing slot is collected" + (heldIn (EbHash 100) (stVolatileBody (pruneBelow (Slot 6) st1))) + , testCase "BEH-Completion: finishing a body write enqueues a body offer" $ do let (st, _) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) From 34382223bb50cdf7f5c533e9279f4e8bf5477bdb Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 17:19:02 -0400 Subject: [PATCH 13/16] WIP update SPEC-DRIFT.md --- .../Test/Leios/RefModel/SPEC-DRIFT.md | 65 +++++++++++++++++-- 1 file changed, 58 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md index f1b68f851b..40e6cf793c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md @@ -56,6 +56,15 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — the EbHash↦… reverse indexes "Derived (NOT stored)"; RefModel bakes that reverse index into EbHashMap (a maintained bidirectional index). The "derived/deferred" framing for `electionOf`/`offerersBody`/`offerersClosure` needs revisiting. +- [ ] **`HeldEbHashSet`** (its own module). The order-agnostic, **`Slot`-keyed** held-EB relation backing + `LstVolatileBody`/`LstVolatileClosure`: a `Map EbHash RefCount` (a multiset, for O(log) `member`) + plus a `Map Slot (NESet EbHash)` (the relation). Keyed by `Slot`, **not `Election`**: the keys are + only consumed by slot-granular GC (`prune`), and only a `(Slot, EbHash)` reference is persisted and + reconstructable on startup, so the `PoolId` half of an election would be dead weight here. `insert` + is **total** — a slot normally references at most two EBs (its first-announced and its certified + one), but slot battles and a bounded sequence of restarts can exceed that, so it never fails (the + `EbHashMap`'s ≤2-then-`error` contract does **not** apply). `member` is by `EbHash` (multiset count + `> 0`), independent of slot. ## §2 State @@ -87,12 +96,14 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — `notifyPriority`-ordered `Set`. Overflow = **tail-drop** (drop the newest message being added). Remove `notifyPriority`, the whole **Helper-functions §2 entry and its two-slot-ordered-queues Aside** (moot), and the `Set`/priority eviction wording. -- [ ] **NEW: `LstVolatileBody` / `LstVolatileClosure`** (`EbHashMap () ()` each) — the in-memory sets of - EBs whose body / full closure we hold. INVARIANT closure ⊆ body. Maintained: body added on - `LevDiskDone` body-write, closure added on completion; **trimmed by Promotion** (`pruneBelow` at - `LevImmTipAdvanced`). `LstVolatileClosure` is ChainSel's queryable "available complete closures" set - (no disk read); `NotifyVotingAndChainSel` is the "set grew" signal. (LeiosDb may ultimately own it; - Spec should still specify the maintenance.) +- [ ] **NEW: `LstVolatileBody` / `LstVolatileClosure`** (a **`HeldEbHashSet`** each, its own module — see + "New abstraction" above) — the in-memory sets of EBs whose body / full closure we hold. INVARIANT + closure ⊆ body. Maintained: body added on `LevDiskDone` body-write, closure added on completion, and + **a fresh first-announcement or cert extends a held EB's references** (`anchorVolatile`); **trimmed + by Promotion** (`pruneBelow` at `LevImmTipAdvanced`, now a `Slot -> Bool` predicate). `LstVolatileClosure` + is ChainSel's queryable "available complete closures" set (no disk read); `NotifyVotingAndChainSel` + is the "set grew" signal. **Reconstructed from disk on startup** (`initSt`; see the Startup section) — + it is the only central state rebuilt across a restart. - [ ] **`Req` dropped its `Election`** (`ReqBody EbHash bs cs | ReqJob EbHash JobId Job`); likewise `DiskWrite` (`WriteBody Body | WriteClosure EbHash [Tx]`). Spec §2 carries `el` in both. - [ ] **`Notification`** offer ctors dropped the election (`NotifyBlockOffer EbHash` / @@ -116,6 +127,14 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — keyed by `(Slot, EbHash)` (obviating the wallclock TTL), but we deliberately kept dedup per-`EbHash` + TTL for now — only `(a)` of the CIP-alignment was adopted. `notifyMsgSlot` now reads the stale horizon's slot straight off the offer message (the old `youngestAnnouncedSlot` is gone). +- [ ] **`MsgLeiosBlockTxsRequest(ebHash, bitfield)`** — the txs argument is now a **bitfield of positions** + into the EB body's `bodyTxlist` (`NonEmpty Word16`, the set-bit positions), not `NonEmpty TxHash`. + Matches the real wire's `TxBitmaps`; the model takes the abstract position-set form (no `Data.Bits`). + `Job` carries `(Word16, TxHash)` pairs — `jobPositions` feeds the request, `jobTxs` still validates + the response against the expected hashes. The store resolves positions itself: + **`dbReadClosureTxs :: EbHash -> NonEmpty Word16 -> m [Tx]`** (was `[TxHash]`), so `hServeTxs` is one + DB call + a length check (no separate body read; an out-of-range position ⇒ short result ⇒ + `RequestedAbsentData`). The response `MsgLeiosBlockTxs(ebHash, [Tx])` is unchanged (request-only change). ## §3 Rules @@ -148,7 +167,39 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — election. (Two *uncertified* announcements for one election remain ordinary equivocation — recorded via the equiv machinery, never a disconnect; an honest peer can relay producer equivocation.) - [ ] **`LevCertValidated`**: uses `supersede` into the `EbHashMap` (and `deleteElection` when already - complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. + complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. The "already + complete?" test and the body-present anchoring now live in the Startup section below. + +## Startup / restart reconstruction (NEW — not in Spec) + +- [ ] **`initSt :: Monad m => LeiosDb m -> m St`** — on node startup, rebuild `LstVolatileBody` / + `LstVolatileClosure` from persisted references intersected with disk presence: for each recorded + `(Slot, EbHash)`, body on disk ⇒ add to `LstVolatileBody`; all of its closure txs present ⇒ also + `LstVolatileClosure`. **The other central state (`LstFirstAnnouncements`, `LstWanted`, `LstCertified`) + is deliberately NOT reconstructed.** MVP rationale: restarts are rare/bounded, so we accept the + laxity — we may repeat some work, and an equivocation slot may transiently drive a `HeldEbHashSet` + above two EBs (hence its total `insert`). Takes only `LeiosDb` (TxCache/Mempool can't matter at + startup). +- [ ] **NEW `DiskOp` `RecordRef Slot EbHash`** — persists a first-announced / certified reference. + **Fire-and-forget: it yields no `LevDiskDone`** and is not part of the persist-before-expose write + count; `GarbageCollect` prunes it by slot, `Promote` ignores it. Emitted on every **first + announcement** (`centralAnnounce`'s `Nothing` branch) and every **`hCertValidated`**. (These are + exactly the references `stVolatile*` ever holds — `electionsNaming` yields precisely the + first-announced ∪ certified elections — so persisting just these reconstructs `stVolatile*`. OK to + record refs for EBs whose body/closure we never acquire; `initSt` simply finds nothing on disk.) +- [ ] **NEW `LeiosDb` method `dbReadAllRefs :: m [(Slot, EbHash)]`** — read all persisted references (for + `initSt`). +- [ ] **`hCertValidated` completeness is now in-memory; `isComplete` is deleted.** The "already complete" + test is `heldIn eh LstVolatileClosure` (authoritative across restart because `initSt` rebuilds the + set), not a disk read — so the handler no longer touches the disk (keeps `Ifaces` only for the + `txCacheEvictForValidCert` hook). The old `isComplete` (a restart-time `dbReadBody` + `dbQueryPresent` + check) is gone. The `supersedeWant` (not-yet-complete) branch additionally **`anchorVolatile`s the + cert's election into `LstVolatileBody`** (when the body is held): this keeps the in-memory held set + equal to what `initSt` would reconstruct from the persisted cert ref, and keeps the body anchored to + the cert's slot so it survives GC of the announcing election's slot. (`recordCompleteCert` already + anchored both sets.) No body-present *resume* branch was added: in steady state the in-flight + `AwaitingTxs` progress is preserved (the `WantState` keep-left `Semigroup` under `supersede`), and the + only restart case that re-fetches a body already on disk is the accepted MVP laxity. ## §7 TxCache occupancy (equivocation-resistant) From 827ebdd9bc5230bb67b2be3377149cfd2b884096 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Sun, 28 Jun 2026 19:24:44 -0400 Subject: [PATCH 14/16] WIP my review --- .../Test/Leios/RefModel/RefModel.hs | 585 ++++++++++-------- .../Test/Leios/RefModel/SPEC-DRIFT.md | 45 +- .../Test/Leios/RefModel/test/RefModelTest.hs | 41 +- 3 files changed, 380 insertions(+), 291 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 180c2ca2e7..1f8ccc342e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module RefModel (module RefModel) where import Control.Monad (foldM) @@ -149,7 +151,7 @@ decTxsState t = case txsWrites t of n -> mkTxsState (txsFetch t) (n - 1) setTxs :: EbHash -> Map JobId Job -> Word16 -> St -> St -- §2 LstWanted AwaitingTxs (callers always pass ≥ 1 outstanding write) -setTxs eh jobs writes st = case mkTxsState jobs writes of +setTxs eh !jobs !writes st = case mkTxsState jobs writes of Just t -> updateWant eh (\_ -> Just (AwaitingTxs t)) st Nothing -> error "setTxs: no outstanding writes (completion is handled only by decWrite)" @@ -170,11 +172,12 @@ data PeerInfo = PeerInfo { peerClass :: Class, peerPhase :: Phase } -- §2 LstP data Notification -- §2 LstPeerNotifyQueue = NotifyAnnouncement RbHeader - | NotifyEquivProof (Maybe RbHeader) RbHeader - | NotifyBlockOffer EbHash -- MsgLeiosBlockOffer - | NotifyBlockTxsOffer EbHash -- MsgLeiosBlockTxsOffer + | NotifyEquivProof RbHeader RbHeader + | NotifyOffer EbHash OfferLevel -- MsgLeiosBlockOffer / MsgLeiosBlockTxsOffer deriving (Eq, Ord, Show) +----- + infixr 1 :-> type k :-> v = Map k v @@ -185,17 +188,17 @@ data PeerOfferings = -- §2 LstPeerOfferings (offer levels; per-election ChainS deriving (Eq, Show) data St = St - { stFirstAnnouncements :: Election :-> AnnState -- §2 LstFirstAnnouncements - , stPeerFirstAnnouncements :: Peer :-> Election :-> AnnSeen -- §2 LstPeerFirstAnnouncements - , stPeerOfferings :: Peer :-> PeerOfferings -- §2 LstPeerOfferings - , stPeerOfferGates :: Peer :-> EbHashMap (Maybe OfferLevel) -- §2 LstPeerOfferGates (payload: offer level sent so far) - , stPeerNotifyQueue :: Peer :-> (Seq Notification, Int) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) - , stWanted :: EbHashMap WantState -- §2 LstWanted - , stVolatileBody :: HeldEbHashSet -- §2 LstVolatileBody - , stVolatileClosure :: HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) - , stCertified :: Election :-> (HeaderHash, EbHash) -- §2 LstCertified - , stPeerInflight :: Peer :-> MiniProtocol :-> Seq Req -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) - , stPeerPresent :: Peer :-> PeerInfo -- §2 LstPeerPresent + { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements + , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements + , stPeerOfferings :: !(Peer :-> PeerOfferings) -- §2 LstPeerOfferings + , stPeerOfferGates :: !(Peer :-> EbHashMap (Maybe OfferLevel)) -- §2 LstPeerOfferGates (payload: offer level sent so far) + , stPeerNotifyQueue :: !(Peer :-> (Seq Notification, Int)) -- §2 LstPeerNotifyQueue (FIFO; cap = credits) + , stWanted :: !(EbHashMap WantState) -- §2 LstWanted + , stVolatileBody :: !HeldEbHashSet -- §2 LstVolatileBody + , stVolatileClosure :: !HeldEbHashSet -- §2 LstVolatileClosure (INVARIANT: subset of stVolatileBody) + , stCertified :: !(Election :-> (HeaderHash, EbHash)) -- §2 LstCertified + , stPeerInflight :: !(Peer :-> MiniProtocol :-> Seq Req) -- §2 LstPeerInflight (one FIFO per LeiosFetch sub-protocol) + , stPeerPresent :: !(Peer :-> PeerInfo) -- §2 LstPeerPresent } deriving (Eq, Show) @@ -232,6 +235,8 @@ peerChainSync peer st = let PeerOfferings _ c = peerOfferings peer st in c modifyPeerOfferings :: Peer -> (PeerOfferings -> PeerOfferings) -> St -> St -- §2 LstPeerOfferings modifyPeerOfferings peer f st = st { stPeerOfferings = Map.insert peer (f (peerOfferings peer st)) (stPeerOfferings st) } +----- + data Env = Env { envStakeMaxActiveEbs :: Int -- §2 stakeMaxActiveEbs , envPeerSharingMaxActiveEbs :: Int -- §2 peerSharingMaxActiveEbs @@ -253,6 +258,8 @@ maxActiveEbs env PeerSharingSampled = envPeerSharingMaxActiveEbs env belowTip :: Env -> Election -> Bool -- BEH-ImmTipAdvance belowTip env el = electionSlot el < envImmutableTip env +----- + data DbKey = DbBody EbHash | DbClosureTx EbHash TxHash -- §2 dbQueryPresent keys deriving (Eq, Ord, Show) @@ -268,6 +275,7 @@ data TxCache m = TxCache -- §7 TxCache hooks , txCacheEvictForValidCert :: Election -> EbHash -> m () -- BEH-Wanting , txCacheOnBody :: EbHash -> Set TxHash -> m [Tx] -- BEH-ChunkJobs , txCacheOnAcquire :: [Tx] -> m () -- BEH-Responses + -- TODO the txCacheOnAcquire IO should also go through SubmitDisk } data Mempool m = Mempool -- §2 Reads of un-owned state @@ -297,7 +305,6 @@ data Stimulus -- §2 Stimuli | LevTimer Time Peer -- BEH-Timeout (a peer's reply-gap timer elapsed) | LevDiskDone DiskWrite -- §3 LevDiskDone (only writes signal completion) | LevImmTipAdvanced -- BEH-ImmTipAdvance (slot read from envImmutableTip) - | LevGarbageCollect Slot -- BEH-ImmTipAdvance | LevSelfIssued RbHeader Body -- BEH-SelfIssued | LevNotifyDequeue Peer -- BEH-NotifyServe deriving (Eq, Show) @@ -309,15 +316,14 @@ data DiskWrite -- §2 disk store interface data DiskOp -- §2 disk store interface (scheduled actions) = Write DiskWrite - | GarbageCollect Slot - | Promote Slot - | RecordRef Slot EbHash -- BEH-Startup: persist a first-announced/certified reference (fire-and-forget, no LevDiskDone; pruned by GarbageCollect, ignored by Promote) + | RecordRef Slot EbHash -- BEH-Startup: persist a first-announced/certified reference (fire-and-forget, no LevDiskDone; the disk reclaims it by slot) deriving (Eq, Show) data Offence -- §3 disconnect reasons (carried by Disconnect) = NotAnAnnouncement -- a LeiosNotify announcement that announces no EB | InvalidHeader -- header failed validation | AnnouncementBound -- re-announced, or exceeded the per-peer two-first-announcements bound + | HalfEquivocationProof -- peer claimed equivocation without having provided two announcements | BogusEquivocationProof -- did not prove a genuine equivocation | UnannouncedOffer -- offered an EB the peer never first-announced | RedundantOffer -- an offer that raised no EB's LeiosNotify level @@ -329,6 +335,7 @@ data Offence -- §3 disconnect reasons (c | RequestTimeout -- a peer let envRequestTimeout elapse without replying while requests were outstanding | ExcessNotifyCredits -- extended more notify credits than notifyMaxCapacity allows | StaleNotification -- a LeiosNotify message whose slot is > notifyStaleHorizon below the immutable tip + | RedundantEquivProof -- an equivocation proof carrying a first header the peer had already announced to us deriving (Eq, Ord, Show) data Effect -- §2 Actions @@ -383,10 +390,10 @@ jobBytes st eh j = wantStateOf :: St -> EbHash -> Maybe WantState -- §2 LstWanted wantStateOf st eh = (\(EM.RefCounts _ _ ws) -> ws) <$> EM.lookupEb eh (stWanted st) -activelyWantsEh :: St -> EbHash -> Bool -- §2 LstWanted (the EB is some election's active want) -activelyWantsEh st eh = case EM.lookupEb eh (stWanted st) of - Just (EM.RefCounts act _ _) -> act > 0 - Nothing -> False +activeWantStateOf :: St -> EbHash -> Maybe WantState -- §2 LstWanted (the WantState iff the EB is some election's active want) +activeWantStateOf st eh = case EM.lookupEb eh (stWanted st) of + Just (EM.RefCounts act _ ws) | act > 0 -> Just ws + _ -> Nothing wantedEbs :: St -> [EbHash] -- §2 LstWanted · NEEDS-TO-BE-INCREMENTAL: maintained wanted-EB set wantedEbs st = let EM.EbHashMap ebs _ = stWanted st in Map.keys (Map.filter (\(EM.RefCounts act _ _) -> 0 < act) ebs) @@ -434,24 +441,30 @@ offeredWanted st peer = fetchPriorityOrder :: St -> [EbHash] -> [EbHash] -- BEH-FetchPriority · NEEDS-TO-BE-INCREMENTAL: maintained priority order, not a per-decision re-sort fetchPriorityOrder st ebs = sortOn (priorityKey st) ebs -newtype NotificationPriority = NotificationPriority Word64 +newtype Priority = Priority Word64 + deriving (Eq, Num, Ord, Show) + +newtype SlotPriority = SlotPriority Word64 deriving (Eq, Num, Ord, Show) -priorityKey :: St -> EbHash -> (NotificationPriority, Slot) +priorityKey :: St -> EbHash -> (Priority, SlotPriority) priorityKey st eh = case electionsNaming eh st of [] -> (2, Slot 0) els -> case [ electionSlot el | el <- els, isCertifiedEb st el eh ] of - (s : _) -> (0, s) - [] -> (1, invertSlot (maximum (map electionSlot els))) + (s : _) -> (0, freshestLast s) + [] -> (1, freshestFirst (maximum (map electionSlot els))) isCertifiedEb :: St -> Election -> EbHash -> Bool isCertifiedEb st el eh = case Map.lookup el (stCertified st) of Just (_, ceb) -> ceb == eh Nothing -> False -invertSlot :: Slot -> Slot -invertSlot (Slot s) = Slot (maxBound - s) +freshestLast :: Slot -> SlotPriotiy +freshestLast (Slot s) = SlotPriotiy (maxBound - s) + +freshestFirst :: Slot -> SlotPriotiy +freshestFirst (Slot s) = SlotPriotiy s decide :: Env -> St -> Peer -> [Req] -- §3 Decision · BEH-BodyFetch · BEH-ClosureFetch · BEH-FetchPriority decide env st peer = @@ -486,6 +499,7 @@ decideForEb env st peer cls eh = peerShareJobs :: Env -> St -> Peer -> EbHash -> Map JobId Job -> [Req] -- §3 PeerShare closure · BEH-ClosureFetch peerShareJobs env st peer eh jobs = + -- TODO low/high-water mark let budget = envPeerSharingClosureByteLimit env - peerSharingInFlightBytes st peer eh candidates = sortOn (\(j, _) -> (jobInflightPeers st eh j, frontSkewKey j)) [ (j, job) | (j, job) <- Map.toList jobs @@ -510,8 +524,8 @@ batchBySize :: (a -> ByteCount) -> ByteCount -> [a] -> [[a]] -- §2 jobSize batchBySize _ _ [] = [] batchBySize size limit (x : xs) = go [x] (size x) xs where - go acc _ [] = [reverse acc] - go acc sz (t : ts) + go acc !_ [] = [reverse acc] + go acc !sz (t : ts) | sz + size t > limit && not (null acc) = reverse acc : go [t] (size t) ts | otherwise = go (t : acc) (sz + size t) ts @@ -531,7 +545,6 @@ step ifs env now stim st = case stim of LevTimer _ peer -> hTimer peer st LevDiskDone w -> hDiskDone ifs env now w st LevImmTipAdvanced -> hImmTipAdvanced env st - LevGarbageCollect s -> hGarbageCollect s st LevSelfIssued h body -> hSelfIssued ifs env now h body st LevNotifyDequeue peer -> hNotifyDequeue env peer st @@ -558,6 +571,35 @@ stepWired ifs env now peer msg st = case notifyMsgSlot st peer msg of MsgLeiosBlockTxsRequest eh poss -> hServeTxs ifs env now peer eh poss st MsgLeiosBlockTxs eh txs -> hBlockTxs ifs env now peer eh txs st +notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot +notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) +notifyMsgSlot _ _ (MsgLeiosBlockEquivocationProof _ h2) = Just (electionSlot (rbElection h2)) +notifyMsgSlot _ _ (MsgLeiosBlockOffer sl _) = Just sl +notifyMsgSlot _ _ (MsgLeiosBlockTxsOffer sl _) = Just sl +notifyMsgSlot _ _ _ = Nothing + +notifyStale :: Env -> Slot -> Bool -- BEH-NotifyServe staleness: slot-difference (as a duration) exceeds notifyStaleHorizon +notifyStale env (Slot s) = case envImmutableTip env of Slot tip -> tip > s + envNotifyStaleHorizon env + +----- + +enqueueToAll :: Notification -> St -> (St, [Effect]) -- BEH-NotifyServe relay +enqueueToAll n st0 = + foldl' + (\(st, fx) peer -> let (st', fx') = enqueueTo peer st in (st', fx ++ fx')) + (st0, []) + (Map.keys (stPeerPresent st0)) + where + enqueueTo peer st = + (setQueue peer (q', cap) st, [ NotifyEnqueue peer | Seq.length q' > Seq.length q ]) + where + (q, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) + q' + | Seq.length q < cap = q Seq.|> n + | otherwise = q + +----- + hAnnouncement :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockAnnouncement hAnnouncement ifs env now peer h st = case rbAnnounce h of Nothing -> pure (st, [Disconnect peer NotAnAnnouncement]) @@ -566,18 +608,97 @@ hAnnouncement ifs env now peer h st = case rbAnnounce h of | otherwise -> case advancePeerAnn peer (rbElection h) h st of Nothing -> pure (st, [Disconnect peer AnnouncementBound]) - Just st1 -> centralAnnounce ifs env now h (copyAnnIntoOfferings peer (rbElection h) st1) + Just st1 -> centralAnnounce ifs env now h (inheritPriorOffers peer (rbElection h) st1) + +advancePeerAnn :: Peer -> Election -> RbHeader -> St -> Maybe St -- §3 LevBlockAnnouncement per-peer check +advancePeerAnn peer el h st = + case Map.lookup el perPeer of + Nothing -> Just (putSeen (SeenOne h)) + Just (SeenOne h1) + | rbHeaderHash h1 == rbHeaderHash h -> Nothing + | otherwise -> Just (putSeen (SeenTwo h1)) + Just (SeenTwo{}) -> Nothing + where + perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)) + + putSeen seen = st + { stPeerFirstAnnouncements = + Map.insert peer + (Map.insert el seen perPeer) + (stPeerFirstAnnouncements st) } + +centralAnnounce :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> St -> m (St, [Effect]) -- §3 LevBlockAnnouncement central branch +centralAnnounce ifs env _now h st = case rbAnnounce h of + Nothing -> pure (st, []) + Just ann -> + let el = rbElection h + eh = annEbHash ann + in case Map.lookup el (stFirstAnnouncements st) of + Nothing -> do + txCacheNoteAnnouncement (ifTxc ifs) el eh + let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } + nowAvailable = heldIn eh (stVolatileClosure st1) + && not (belowTip env el) + st2 = anchorVolatile el eh st1 + st3 | belowTip env el = st2 + | heldIn eh (stVolatileClosure st2) = st2 + | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 + (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 + (st5, fx') = enqueueHeldOffers eh st4 + pure (st5, fx ++ fx' ++ [ SubmitDisk (RecordRef (electionSlot el) eh) ] + ++ [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st1) | nowAvailable ]) + Just (AnnOne h1) + | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) + | otherwise -> + let st1 = st { stFirstAnnouncements = Map.insert el (AnnTwo h1 h) (stFirstAnnouncements st) } + in pure (if Map.member el (stCertified st) then (st1, []) else enqueueToAll (NotifyEquivProof h1 h) st1) + Just (AnnTwo{}) -> pure (st, []) + +anchorVolatile :: Election -> EbHash -> St -> St -- §2 LstVolatileBody/Closure: a fresh announcement extends a held EB's elections +anchorVolatile el eh st = st + { stVolatileBody = if heldIn eh (stVolatileBody st) then addVolatile eh [el] (stVolatileBody st) else stVolatileBody st + , stVolatileClosure = if heldIn eh (stVolatileClosure st) then addVolatile eh [el] (stVolatileClosure st) else stVolatileClosure st } + +enqueueHeldOffers :: EbHash -> St -> (St, [Effect]) -- BEH-Offers · BEH-Completion: offer a held EB to peers we are announcing it to +enqueueHeldOffers eh st + | heldIn eh (stVolatileClosure st) = enqueueToAll (NotifyOffer eh OfferBodyAndClosure) st + | heldIn eh (stVolatileBody st) = enqueueToAll (NotifyOffer eh OfferBody) st + | otherwise = (st, []) + +inheritPriorOffers :: Peer -> Election -> St -> St -- BEH-Offers · §2 LstPeerOfferings +inheritPriorOffers peer el st = case firstAnnouncedEb st peer el of + Just eh | offered eh -> anchorOffer peer el eh st + _ -> st + where + offered eh = isJust (EM.lookupEb eh (peerOfferingsEbm peer st)) + +-- | PREREQ: eh is el's first-announced for this peer +anchorOffer :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferings +anchorOffer peer el eh st = + case EM.activeRef <$> EM.lookupElection el (peerOfferingsEbm peer st) of + Just act | act /= eh -> st -- eh must be its inactive, which we mustn't upsert again + _ -> modifyPeerOfferings peer (\(PeerOfferings m c) -> PeerOfferings (EM.upsert eh el (Nothing, Any False) m) c) st + +----- hEquivProof :: Monad m => Env -> Peer -> Maybe RbHeader -> RbHeader -> St -> m (St, [Effect]) -- BEH-Wanting · §3 LevBlockEquivocationProof -hEquivProof env peer mh1 h2 st = - case maybe (recordedFirst st peer (rbElection h2)) Just mh1 of - Nothing -> pure (st, [Disconnect peer BogusEquivocationProof]) - Just h1 - | not (genuineEquiv h1 h2) -> pure (st, [Disconnect peer BogusEquivocationProof]) - | otherwise -> case advancePeerToTwo peer (rbElection h2) h1 st of - Nothing -> pure (st, [Disconnect peer BogusEquivocationProof]) - Just st1 -> let (st2, fx) = centralEquiv env (rbElection h2) h1 h2 st1 - in pure (st2, fx) +hEquivProof env peer mh1 h2 st + | Map.member (rbElection h2) (stCertified st) = pure (st, []) + | otherwise = case collateH1 of + Left offence -> pure (st, [Disconnect peer offence]) + Right h1 + | not (genuineEquiv h1 h2) -> pure (st, [Disconnect peer BogusEquivocationProof]) + | otherwise -> case advancePeerToTwo peer (rbElection h2) h1 st of + Nothing -> pure (st, [Disconnect peer BogusEquivocationProof]) + Just st1 -> let (st2, fx) = centralEquiv env (rbElection h2) h1 h2 st1 + in pure (st2, fx) + where + collateH1 = + case (recordedFirst st peer (rbElection h2), mh1) of + (Nothing, Nothing) -> Left HalfEquivocationProof + (Just {}, Just {}) -> Left RedundantEquivProof + (Just x, Nothing) -> Right x + (Nothing, Just x) -> Right x recordedFirst :: St -> Peer -> Election -> Maybe RbHeader -- §2 LstPeerFirstAnnouncements recordedFirst st peer el = do @@ -603,21 +724,25 @@ advancePeerToTwo peer el h1 st = Just (SeenTwo{}) -> Nothing centralEquiv :: Env -> Election -> RbHeader -> RbHeader -> St -> (St, [Effect]) -- §3 LevBlockEquivocationProof central branch -centralEquiv env el h1 h2 st = +centralEquiv env el peerh1 peerh2 st = case Map.lookup el (stFirstAnnouncements st) of Just (AnnTwo{}) -> (st, []) - prev -> + Just (AnnOne myh) -> + k False myh $ if rbHeaderHash myh == rbHeaderHash peerh1 then peerh2 else peerh1 + Nothing -> k True peerh1 peerh2 + where + k wasEmpty h1 h2 = let st1 = st { stFirstAnnouncements = Map.insert el (AnnTwo h1 h2) (stFirstAnnouncements st) } - st2 = case prev of - Nothing | not (belowTip env el) -> ensureWantedBodyAnn st1 el h1 - _ -> st1 - in enqueueToAll (NotifyEquivProof (Just h1) h2) st2 + st2 = if wasEmpty && not (belowTip env el) then ensureWantedBodyAnn st1 el h1 else st1 + in enqueueToAll (NotifyEquivProof h1 h2) st2 ensureWantedBodyAnn :: St -> Election -> RbHeader -> St ensureWantedBodyAnn st el h = case rbAnnounce h of Just a -> wantBody el (annEbHash a) (annBodySize a) (annClosureSize a) st Nothing -> st +----- + hOffer :: Monad m => Env -> Time -> Peer -> Slot -> EbHash -> OfferLevel -> St -> m (St, [Effect]) -- BEH-Offers · §3 LevBlockOffer / LevBlockTxsOffer hOffer env now peer sl eh lvl st = case filter ((== sl) . electionSlot) (electionsFirstAnnouncing st peer eh) of [] -> pure (st, [Disconnect peer UnannouncedOffer]) @@ -627,22 +752,24 @@ hOffer env now peer sl eh lvl st = case filter ((== sl) . electionSlot) (electio where raiseOffer els0 s = foldl' (\acc el -> anchorOffer peer el eh acc) s els0 notifyOf s = - let perPeer = peerOfferingsEbm peer s - bump (Just (LeiosNotifySide cl ct), chain) - | lvl > cl = Just (Just (LeiosNotifySide lvl now), chain) - | staleOffer env now ct = Just (Just (LeiosNotifySide lvl now), chain) - | otherwise = Nothing - bump (Nothing, chain) = Just (Just (LeiosNotifySide lvl now), chain) - in (\m -> modifyPeerOfferings peer (\(PeerOfferings _ c) -> PeerOfferings m c) s) <$> EM.updateEb eh bump perPeer + (\ebm -> modifyPeerOfferings peer (\(PeerOfferings _ c) -> PeerOfferings ebm c) s) + <$> EM.updateEb eh bump (peerOfferingsEbm peer s) + bump (Just (LeiosNotifySide cl ct), _) + | lvl <= cl && not (staleOffer env now ct) = Nothing + bump (_, chain) = Just (Just (LeiosNotifySide lvl now), chain) + +staleOffer :: Env -> Time -> Time -> Bool -- §3 RedundantOffer TTL: the peer's prior offer is older than the dedup epoch +staleOffer env (Time n) (Time t) = n >= t + envOfferDedupTtl env hRollForward :: Monad m => Ifaces m -> Env -> Time -> Peer -> RbHeader -> Maybe AnnouncementTriple -> St -> m (St, [Effect]) -- BEH-Offers / BEH-Wanting · §3 LevRollForward -hRollForward ifs env now peer h pe st = do +hRollForward ifs env now peer h mbPrev st = do (st1, fx1) <- case rbAnnounce h of Nothing -> pure (st, []) Just _ -> centralAnnounce ifs env now h st - let (st2, fx2) = case (rbHasLeiosCert h, pe) of + let (st2, fx2) = case (rbHasLeiosCert h, mbPrev) of (True, Just at) -> rollForwardCert peer at st1 - _ -> (st1, []) + (True, Nothing) -> error "impossible! ChainSync client should have rejected this header" + (False, _) -> (st1, []) considerFetchAfter env now st2 (fx1 ++ fx2) rollForwardCert :: Peer -> AnnouncementTriple -> St -> (St, [Effect]) -- §3 LevRollForward cert bit @@ -661,16 +788,24 @@ rollForwardCert peer at st = recordChainSyncSide :: Peer -> Election -> HeaderHash -> EbHash -> St -> St -- §3 LevRollForward cert bit recordChainSyncSide peer el hh eh st = case EM.lookupElection el (peerOfferingsEbm peer st) of - Just (EM.Refs EM.NoInactiveRef _) -> st - Just (EM.Refs (EM.InactiveRef _) _) -> st - _ -> modifyPeerOfferings peer (\(PeerOfferings m c) -> PeerOfferings (EM.supersede el eh (Nothing, Any True) m) (Map.insert el (ChainSyncSide hh) c)) st + Just (EM.Refs EM.NoInactiveRef _) -> st -- already superseded + Just (EM.Refs EM.InactiveRef{} _) -> st -- already superseded + _ -> modifyPeerOfferings peer + (\(PeerOfferings m c) -> + PeerOfferings + (EM.supersede el eh (Nothing, Any True) m) + (Map.insert el (ChainSyncSide hh) c) + ) + st hRequestNext :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotificationRequestNext hRequestNext env peer st = let (s, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) in if cap >= envNotifyMaxCapacity env then pure (st, [Disconnect peer ExcessNotifyCredits]) - else pure (setQueue peer (s, cap + 1) st, []) + else let !cap' = cap + 1 in pure (setQueue peer (s, cap') st, []) + +----- hNotifyDequeue :: Monad m => Env -> Peer -> St -> m (St, [Effect]) -- BEH-NotifyServe · §3 LevNotifyDequeue hNotifyDequeue env peer st = @@ -679,62 +814,46 @@ hNotifyDequeue env peer st = Empty -> error "hNotifyDequeue: LevNotifyDequeue on an empty queue" n :<| q' | discard -> pure (setQueue peer (q', cap) st, []) - | otherwise -> pure (sendNotification peer n (setQueue peer (q', cap - 1) st)) + | otherwise -> let !cap' = cap - 1 in pure (sendNotification peer n (setQueue peer (q', cap') st)) where discard = case n of NotifyAnnouncement h -> belowTip env (rbElection h) - NotifyEquivProof _ h2 -> belowTip env (rbElection h2) - NotifyBlockOffer eh -> not (offerable peer eh OfferBody st) - NotifyBlockTxsOffer eh -> not (offerable peer eh OfferBodyAndClosure st) + NotifyEquivProof h1 _ -> belowTip env (rbElection h1) + NotifyOffer eh lvl -> not (offerable peer eh lvl st) setQueue :: Peer -> (Seq Notification, Int) -> St -> St setQueue peer v st = st { stPeerNotifyQueue = Map.insert peer v (stPeerNotifyQueue st) } -enqueue :: Notification -> (Seq Notification, Int) -> (Seq Notification, Int) -- BEH-NotifyServe (FIFO; drop the new message when full) -enqueue n (q, cap) - | Seq.length q < cap = (q Seq.|> n, cap) - | otherwise = (q, cap) - -enqueueTo :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe -enqueueTo peer n st = - let (q, cap) = fromMaybe (Seq.empty, 0) (Map.lookup peer (stPeerNotifyQueue st)) - (q', _) = enqueue n (q, cap) - in (setQueue peer (q', cap) st, [ NotifyEnqueue peer | Seq.length q' > Seq.length q ]) - -enqueueToAll :: Notification -> St -> (St, [Effect]) -- BEH-NotifyServe relay -enqueueToAll n st = foldl' (\(s, fx) peer -> let (s', fx') = enqueueTo peer n s in (s', fx ++ fx')) (st, []) (Map.keys (stPeerPresent st)) - offerable :: Peer -> EbHash -> OfferLevel -> St -> Bool -- §2 LstPeerOfferGates: announced, and not yet offered at this level offerable peer eh lvl st = case EM.lookupEb eh (fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st))) of Just (EM.RefCounts _ _ sent) -> sent < Just lvl Nothing -> False -notifyMsgSlot :: St -> Peer -> WireMsg -> Maybe Slot -- BEH-NotifyServe staleness: a LeiosNotify message's slot -notifyMsgSlot _ _ (MsgLeiosBlockAnnouncement h) = Just (electionSlot (rbElection h)) -notifyMsgSlot _ _ (MsgLeiosBlockEquivocationProof _ h2) = Just (electionSlot (rbElection h2)) -notifyMsgSlot _ _ (MsgLeiosBlockOffer sl _) = Just sl -notifyMsgSlot _ _ (MsgLeiosBlockTxsOffer sl _) = Just sl -notifyMsgSlot _ _ _ = Nothing - -notifyStale :: Env -> Slot -> Bool -- BEH-NotifyServe staleness: slot-difference (as a duration) exceeds notifyStaleHorizon -notifyStale env (Slot s) = case envImmutableTip env of Slot tip -> tip > s + envNotifyStaleHorizon env - -staleOffer :: Env -> Time -> Time -> Bool -- §3 RedundantOffer TTL: the peer's prior offer is older than the dedup epoch -staleOffer env (Time n) (Time t) = n >= t + envOfferDedupTtl env - sendNotification :: Peer -> Notification -> St -> (St, [Effect]) -- BEH-NotifyServe sendNotification peer n st = case n of NotifyAnnouncement h -> let el = rbElection h - eh = maybe (EbHash 0) annEbHash (rbAnnounce h) + eh = maybe (error "impossible!") annEbHash (rbAnnounce h) in (openGate peer el eh st, [Send peer (MsgLeiosBlockAnnouncement h)]) - NotifyEquivProof m1 h2 -> (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) - NotifyBlockOffer eh -> case gateSlot peer eh st of - Just sl -> (bumpGate peer eh OfferBody st, [Send peer (MsgLeiosBlockOffer sl eh)]) - Nothing -> (st, []) - NotifyBlockTxsOffer eh -> case gateSlot peer eh st of - Just sl -> (bumpGate peer eh OfferBodyAndClosure st, [Send peer (MsgLeiosBlockTxsOffer sl eh)]) - Nothing -> (st, []) + NotifyEquivProof h1 h2 -> + let m1 = if announcedToPeer peer h1 st then Nothing else Just h1 + in (st, [Send peer (MsgLeiosBlockEquivocationProof m1 h2)]) + NotifyOffer eh lvl -> + let msg = case lvl of OfferBody -> MsgLeiosBlockOffer; OfferBodyAndClosure -> MsgLeiosBlockTxsOffer + in case gateSlot peer eh st of + Just sl -> (bumpGate peer eh lvl st, [Send peer (msg sl eh)]) + Nothing -> (st, []) + +openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates: announcement sent (no offer yet) +openGate peer el eh st = + st { stPeerOfferGates = Map.insert peer (EM.upsert eh el Nothing perPeer) (stPeerOfferGates st) } + where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) + +announcedToPeer :: Peer -> RbHeader -> St -> Bool -- §2 LstPeerOfferGates: we already sent this header's announcement to the peer +announcedToPeer peer h st = case annEbHashOf h of + Just eh -> (EM.activeRef <$> EM.lookupElection (rbElection h) gate) == Just eh + Nothing -> False + where gate = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) gateSlot :: Peer -> EbHash -> St -> Maybe Slot -- §2 LstPeerOfferGates: a slot we announced eh to peer under · NEEDS-TO-BE-INCREMENTAL gateSlot peer eh st = @@ -743,29 +862,18 @@ gateSlot peer eh st = (s : _) -> Just s [] -> Nothing -openGate :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferGates: announcement sent (no offer yet) -openGate peer el eh st = - st { stPeerOfferGates = Map.insert peer (EM.upsert eh el Nothing perPeer) (stPeerOfferGates st) } - where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) - bumpGate :: Peer -> EbHash -> OfferLevel -> St -> St -- §2 LstPeerOfferGates: record the offer level sent bumpGate peer eh lvl st = case EM.updateEb eh (\sent -> Just (sent <> Just lvl)) perPeer of Just m' -> st { stPeerOfferGates = Map.insert peer m' (stPeerOfferGates st) } Nothing -> st where perPeer = fromMaybe EM.empty (Map.lookup peer (stPeerOfferGates st)) -validBody :: Env -> EbHash -> ByteCount -> ByteCount -> Body -> Bool -- BEH-Responses: EB-body validation (hash + sizes match the announcement; no single tx exceeds envMaxTxSize) -validBody env eh bs cs body = - bodyEbHash body == eh - && bodyActualSize body == bs - && sum (map txRefSize (bodyTxlist body)) == cs - && all ((<= envMaxTxSize env) . txRefSize) (bodyTxlist body) +----- hBlock :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> Body -> St -> m (St, [Effect]) -- BEH-Responses · BEH-ChunkJobs · §3 LevBlock hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of - Just (ReqBody eh' bs cs) | eh' == eh -> - let st1 = popFront peer FetchBody st - in if not (validBody env eh bs cs body) + Just (ReqBody eh' bs cs, st1) | eh' == eh -> + if not (validBody env eh bs cs body) then pure (st1, [Disconnect peer BodyMismatch]) else case wantStateOf st eh of Just (AwaitingBody _ _) -> do @@ -785,23 +893,26 @@ hBlock ifs env now peer eh body st = case frontReq st peer FetchBody of _ -> considerFetchAfter env now st1 [] _ -> pure (st, [Disconnect peer UnsolicitedResponse]) +validBody :: Env -> EbHash -> ByteCount -> ByteCount -> Body -> Bool -- BEH-Responses: EB-body validation (hash + sizes match the announcement; no single tx exceeds envMaxTxSize) +validBody env eh bs cs body = + bodyEbHash body == eh + && bodyActualSize body == bs + && sum (map txRefSize (bodyTxlist body)) == cs + && all ((<= envMaxTxSize env) . txRefSize) (bodyTxlist body) + hBlockTxs :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> [Tx] -> St -> m (St, [Effect]) -- BEH-Responses · §3 LevBlockTxs hBlockTxs ifs env now peer eh txs st = case frontReq st peer FetchTxs of - Just (ReqJob eh' j job) | eh' == eh -> - let st1 = popFront peer FetchTxs st - in if map txHash txs /= NE.toList (jobTxs job) - then pure (st1, [Disconnect peer TxsMismatch]) - else if not (activelyWantsEh st1 eh) - then considerFetchAfter env now st1 [] - else do - txCacheOnAcquire (ifTxc ifs) txs - let writes = [SubmitDisk (Write (WriteClosure eh txs))] - case wantStateOf st1 eh of - Just (AwaitingTxs t) -> - let jobs' = Map.delete j (txsFetch t) - st2 = setTxs eh jobs' (txsWrites t + 1) st1 - in considerFetchAfter env now st2 writes - _ -> considerFetchAfter env now st1 writes + Just (ReqJob eh' j job, st1) | eh' == eh -> + if map txHash txs /= NE.toList (jobTxs job) then pure (st1, [Disconnect peer TxsMismatch]) else do + txCacheOnAcquire (ifTxc ifs) txs + let writes = [SubmitDisk (Write (WriteClosure eh txs))] + case activeWantStateOf st1 eh of + Nothing -> considerFetchAfter env now st1 [] + Just AwaitingBody{} -> error "impossible!" + Just (AwaitingTxs t) -> + let jobs' = Map.delete j (txsFetch t) + st2 = setTxs eh jobs' (txsWrites t + 1) st1 + in considerFetchAfter env now st2 writes _ -> pure (st, [Disconnect peer UnsolicitedResponse]) hServeBody :: Monad m => Ifaces m -> Env -> Time -> Peer -> EbHash -> St -> m (St, [Effect]) -- BEH-FetchServe · §3 LevBlockRequest @@ -818,21 +929,46 @@ hServeTxs ifs _env _now peer eh poss st = do then pure (st, [Send peer (MsgLeiosBlockTxs eh served)]) else pure (st, [Disconnect peer RequestedAbsentData]) +----- + hCertValidated :: Monad m => Ifaces m -> Env -> Time -> AnnouncementTriple -> ByteCount -> ByteCount -> St -> m (St, [Effect]) -- BEH-Wanting · BEH-FetchPriority · §3 LevCertValidated hCertValidated ifs env now (AnnouncementTriple el hh eh) bs cs st | Map.member el (stCertified st) = pure (st, []) + | belowTip env el = pure (st, []) | otherwise = do txCacheEvictForValidCert (ifTxc ifs) el eh let st1 = setCertified el (hh, eh) st - (st2, fx) | belowTip env el = (st1, []) - | heldIn eh (stVolatileClosure st1) = recordCompleteCert env el eh st1 + (st2, fx) | heldIn eh (stVolatileClosure st1) = recordCompleteCert env el eh st1 | otherwise = (anchorVolatile el eh (supersedeWant el eh bs cs st1), []) considerFetchAfter env now st2 (SubmitDisk (RecordRef (electionSlot el) eh) : fx) +recordCompleteCert :: Env -> Election -> EbHash -> St -> (St, [Effect]) -- BEH-Completion: a cert for an already-complete EB (incl. restart) makes its closure available +recordCompleteCert env el eh st = + let st1 = removeWantEl el st + st2 = st1 { stVolatileBody = addVolatile eh [el] (stVolatileBody st1) + , stVolatileClosure = addVolatile eh [el] (stVolatileClosure st1) } + in (st2, [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st2) ]) + +announcingHeaderHashes :: Env -> EbHash -> St -> [HeaderHash] -- BEH-Completion · NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦announcing-RB index (immtip-or-newer) +announcingHeaderHashes env eh st = + [ rbHeaderHash h + | (el, ann) <- Map.toList (stFirstAnnouncements st) + , not (belowTip env el) + , h <- annStateHeaders ann + , annEbHashOf h == Just eh ] + +annStateHeaders :: AnnState -> [RbHeader] -- §2 LstFirstAnnouncements: the RbHeaders recorded for an election +annStateHeaders (AnnOne h) = [h] +annStateHeaders (AnnTwo h1 h2) = [h1, h2] + +supersedeWant :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (cert validated; once per election) +supersedeWant el eh bs cs st = st { stWanted = EM.supersede el eh (AwaitingBody bs cs) (stWanted st) } + +----- + hPeerAdd :: Monad m => Env -> Peer -> Class -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerAdd (prime the notify client: envNotifyMaxCapacity RequestNext) hPeerAdd env peer cls st = pure - ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) - , stPeerOfferings = Map.insert peer emptyPeerOfferings (stPeerOfferings st) } + ( st { stPeerPresent = Map.insert peer (PeerInfo cls Active) (stPeerPresent st) } , replicate (envNotifyMaxCapacity env) (Send peer MsgLeiosNotificationRequestNext) ) hPeerWindDown :: Monad m => Env -> Time -> Peer -> St -> m (St, [Effect]) -- BEH-PeerChurn · §3 LevPeerWindDown @@ -850,6 +986,8 @@ hPeerRemove env now peer st = , stPeerInflight = Map.delete peer (stPeerInflight st) } in considerFetchAfter env now st1 [] +----- + hTimer :: Monad m => Peer -> St -> m (St, [Effect]) -- BEH-Timeout · §3 LevTimer (disconnect iff still expecting replies) hTimer peer st = pure (st, [Disconnect peer RequestTimeout | not (Seq.null (inflightOf st peer))]) @@ -867,43 +1005,34 @@ decWrite :: Env -> EbHash -> St -> (St, [Effect]) -- §3 LevDiskDone decWrite env eh st = case wantStateOf st eh of Just (AwaitingTxs t) -> case decTxsState t of Just t' -> (updateWant eh (\_ -> Just (AwaitingTxs t')) st, []) - Nothing -> completeEb env eh st + Nothing -> + let els = electionsNaming eh st + st0 = st { stVolatileClosure = addVolatile eh els (stVolatileClosure st) } + (st1, fx) = enqueueClosureOffers eh (removeWantEb eh st0) + in (st1, NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st) : fx) _ -> (st, []) -annStateHeaders :: AnnState -> [RbHeader] -- §2 LstFirstAnnouncements: the RbHeaders recorded for an election -annStateHeaders (AnnOne h) = [h] -annStateHeaders (AnnTwo h1 h2) = [h1, h2] - -announcingHeaderHashes :: Env -> EbHash -> St -> [HeaderHash] -- BEH-Completion · NEEDS-TO-BE-INCREMENTAL: reverse EbHash↦announcing-RB index (immtip-or-newer) -announcingHeaderHashes env eh st = - [ rbHeaderHash h - | (el, ann) <- Map.toList (stFirstAnnouncements st) - , not (belowTip env el) - , h <- annStateHeaders ann - , annEbHashOf h == Just eh ] +----- -completeEb :: Env -> EbHash -> St -> (St, [Effect]) -- BEH-Completion (per-EbHash; notify voting + ChainSel with the announcing RBs) -completeEb env eh st = - let els = electionsNaming eh st - st0 = st { stVolatileClosure = addVolatile eh els (stVolatileClosure st) } - (st1, fx) = enqueueClosureOffers eh (removeWantEb eh st0) - in (st1, NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st) : fx) +hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced +hImmTipAdvanced env st = pure (pruneBelow (envImmutableTip env) st, []) -recordCompleteCert :: Env -> Election -> EbHash -> St -> (St, [Effect]) -- BEH-Completion: a cert for an already-complete EB (incl. restart) makes its closure available -recordCompleteCert env el eh st = - let st1 = removeWantEl el st - st2 = st1 { stVolatileBody = addVolatile eh [el] (stVolatileBody st1) - , stVolatileClosure = addVolatile eh [el] (stVolatileClosure st1) } - in (st2, [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st2) ]) +pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete +pruneBelow s st = st + { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) + , stWanted = EM.pruneElections (\el -> electionSlot el < s) (stWanted st) + , stVolatileBody = Held.prune (< s) (stVolatileBody st) + , stVolatileClosure = Held.prune (< s) (stVolatileClosure st) + , stCertified = pruneElectionMap s (stCertified st) + , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) + , stPeerOfferings = Map.map (\(PeerOfferings m c) -> PeerOfferings (EM.pruneElections (\el -> electionSlot el < s) m) (pruneElectionMap s c)) (stPeerOfferings st) + , stPeerOfferGates = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferGates st) + } -hImmTipAdvanced :: Monad m => Env -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevImmTipAdvanced -hImmTipAdvanced env st = - let s = envImmutableTip env - st1 = pruneBelow s st - in pure (st1, [SubmitDisk (Promote s)]) +pruneElectionMap :: Slot -> Map Election a -> Map Election a +pruneElectionMap s = Map.filterWithKey (\el _ -> not (electionSlot el < s)) -hGarbageCollect :: Monad m => Slot -> St -> m (St, [Effect]) -- BEH-ImmTipAdvance · §3 LevGarbageCollect -hGarbageCollect s st = pure (st, [SubmitDisk (GarbageCollect s)]) +----- hSelfIssued :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> Body -> St -> m (St, [Effect]) -- BEH-SelfIssued · §3 LevSelfIssued hSelfIssued ifs env now h body st = case rbAnnounce h of @@ -924,6 +1053,13 @@ hSelfIssued ifs env now h body st = case rbAnnounce h of st2 = setTxs eh jobsMap (fromIntegral (length writes)) st1 pure (st2, fx ++ writes) +----- + +considerFetchAfter :: Monad m => Env -> Time -> St -> [Effect] -> m (St, [Effect]) +considerFetchAfter env now st fx = do + (st', fx') <- considerFetching env now st + pure (st', fx ++ fx') + considerFetching :: Monad m => Env -> Time -> St -> m (St, [Effect]) -- §3 consider-fetching · NEEDS-TO-BE-INCREMENTAL: reconsider only the affected peer(s)/EB, not every Active peer considerFetching env now st = pure (foldl' go (st, []) (activePeers st)) where @@ -931,44 +1067,31 @@ considerFetching env now st = pure (foldl' go (st, []) (activePeers st)) let new = decide env s peer wasIdle = Seq.null (inflightOf s peer) s' = foldl' (issue peer) s new - fx' = fx ++ concatMap (sendReq s peer) new + fx' = fx ++ [ Send peer (reqWire r) | r <- new ] ++ [ armTimer env now peer | wasIdle, not (null new) ] in (s', fx') -considerFetchAfter :: Monad m => Env -> Time -> St -> [Effect] -> m (St, [Effect]) -considerFetchAfter env now st fx = do - (st', fx') <- considerFetching env now st - pure (st', fx ++ fx') - issue :: Peer -> St -> Req -> St issue peer st r = st { stPeerInflight = Map.insertWith (Map.unionWith (flip (<>))) peer (Map.singleton (reqProtocol r) (Seq.singleton r)) (stPeerInflight st) } -sendReq :: St -> Peer -> Req -> [Effect] -- §3 issue a request -sendReq st peer r = [Send peer (reqWire st r)] - armTimer :: Env -> Time -> Peer -> Effect -- §2 requestTimeout: (re)arm peer's reply-gap timer at now + envRequestTimeout armTimer env (Time now) peer = SetTimer peer (Time (now + envRequestTimeout env)) -reqWire :: St -> Req -> WireMsg -reqWire _ (ReqBody eh _ _) = MsgLeiosBlockRequest eh -reqWire _ (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobPositions job) +reqWire :: Req -> WireMsg +reqWire (ReqBody eh _ _) = MsgLeiosBlockRequest eh +reqWire (ReqJob eh _ job) = MsgLeiosBlockTxsRequest eh (jobPositions job) -frontReq :: St -> Peer -> MiniProtocol -> Maybe Req -frontReq st peer mp = case inflightFifo st peer mp of - r :<| _ -> Just r - _ -> Nothing +----- -popFront :: Peer -> MiniProtocol -> St -> St -popFront peer mp st = st { stPeerInflight = Map.adjust (Map.adjust dropFront mp) peer (stPeerInflight st) } - where dropFront sq = case sq of _ :<| rest -> rest; Empty -> Empty +frontReq :: St -> Peer -> MiniProtocol -> Maybe (Req, St) -- §2 LstPeerInflight: the front Req, paired with the state that has it popped +frontReq st peer mp = case inflightFifo st peer mp of + r :<| rest -> Just (r, st { stPeerInflight = Map.adjust (Map.insert mp rest) peer (stPeerInflight st) }) + _ -> Nothing wantBody :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (announcement; keep existing progress if already wanted) wantBody el eh bs cs st = st { stWanted = EM.upsert eh el (AwaitingBody bs cs) (stWanted st) } -supersedeWant :: Election -> EbHash -> ByteCount -> ByteCount -> St -> St -- §2 LstWanted (cert validated; once per election) -supersedeWant el eh bs cs st = st { stWanted = EM.supersede el eh (AwaitingBody bs cs) (stWanted st) } - updateWant :: EbHash -> (WantState -> Maybe WantState) -> St -> St -- §2 LstWanted (in-place per-EB payload update; no-op if absent) updateWant eh f st = st { stWanted = fromMaybe (stWanted st) (EM.updateEb eh f (stWanted st)) } @@ -982,10 +1105,10 @@ setCertified :: Election -> (HeaderHash, EbHash) -> St -> St setCertified el v st = st { stCertified = Map.insert el v (stCertified st) } enqueueBodyOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) -enqueueBodyOffers eh = enqueueToAll (NotifyBlockOffer eh) +enqueueBodyOffers eh = enqueueToAll (NotifyOffer eh OfferBody) enqueueClosureOffers :: EbHash -> St -> (St, [Effect]) -- BEH-NotifyServe · BEH-Completion (gate-checked at dequeue) -enqueueClosureOffers eh = enqueueToAll (NotifyBlockTxsOffer eh) +enqueueClosureOffers eh = enqueueToAll (NotifyOffer eh OfferBodyAndClosure) addVolatile :: EbHash -> [Election] -> HeldEbHashSet -> HeldEbHashSet -- §2 LstVolatileBody/LstVolatileClosure addVolatile eh els m = foldl' (\acc el -> Held.insert eh (electionSlot el) acc) m els @@ -993,89 +1116,7 @@ addVolatile eh els m = foldl' (\acc el -> Held.insert eh (electionSlot el) acc) heldIn :: EbHash -> HeldEbHashSet -> Bool -- §2 LstVolatileBody/LstVolatileClosure membership heldIn = Held.member -pruneBelow :: Slot -> St -> St -- BEH-ImmTipAdvance range-delete -pruneBelow s st = st - { stFirstAnnouncements = pruneElectionMap s (stFirstAnnouncements st) - , stWanted = EM.pruneElections (\el -> electionSlot el < s) (stWanted st) - , stVolatileBody = Held.prune (< s) (stVolatileBody st) - , stVolatileClosure = Held.prune (< s) (stVolatileClosure st) - , stCertified = pruneElectionMap s (stCertified st) - , stPeerFirstAnnouncements = Map.map (pruneElectionMap s) (stPeerFirstAnnouncements st) - , stPeerOfferings = Map.map (\(PeerOfferings m c) -> PeerOfferings (EM.pruneElections (\el -> electionSlot el < s) m) (pruneElectionMap s c)) (stPeerOfferings st) - , stPeerOfferGates = Map.map (EM.pruneElections (\el -> electionSlot el < s)) (stPeerOfferGates st) - } - -pruneElectionMap :: Slot -> Map Election a -> Map Election a -pruneElectionMap s = Map.filterWithKey (\el _ -> not (electionSlot el < s)) - -advancePeerAnn :: Peer -> Election -> RbHeader -> St -> Maybe St -- §3 LevBlockAnnouncement per-peer check -advancePeerAnn peer el h st = - let perPeer = fromMaybe Map.empty (Map.lookup peer (stPeerFirstAnnouncements st)) - in case Map.lookup el perPeer of - Nothing -> Just (putSeen (SeenOne h)) - Just (SeenOne h1) - | rbHeaderHash h1 == rbHeaderHash h -> Nothing - | otherwise -> Just (putSeen (SeenTwo h1)) - Just (SeenTwo{}) -> Nothing - where - putSeen seen = st - { stPeerFirstAnnouncements = - Map.insert peer - (Map.insert el seen perPeer) - (stPeerFirstAnnouncements st) } - -centralAnnounce :: Monad m => Ifaces m -> Env -> Time -> RbHeader -> St -> m (St, [Effect]) -- §3 LevBlockAnnouncement central branch -centralAnnounce ifs env _now h st = case rbAnnounce h of - Nothing -> pure (st, []) - Just ann -> - let el = rbElection h - eh = annEbHash ann - in case Map.lookup el (stFirstAnnouncements st) of - Nothing -> do - txCacheNoteAnnouncement (ifTxc ifs) el eh - let st1 = st { stFirstAnnouncements = Map.insert el (AnnOne h) (stFirstAnnouncements st) } - nowAvailable = heldIn eh (stVolatileClosure st1) - && not (belowTip env el) - st2 = anchorVolatile el eh st1 - st3 | belowTip env el = st2 - | heldIn eh (stVolatileClosure st2) = st2 - | otherwise = wantBody el eh (annBodySize ann) (annClosureSize ann) st2 - (st4, fx) = enqueueToAll (NotifyAnnouncement h) st3 - (st5, fx') = enqueueHeldOffers eh st4 - pure (st5, fx ++ fx' ++ [ SubmitDisk (RecordRef (electionSlot el) eh) ] - ++ [ NotifyVotingAndChainSel eh (announcingHeaderHashes env eh st1) | nowAvailable ]) - Just (AnnOne h1) - | rbHeaderHash h1 == rbHeaderHash h -> pure (st, []) - | otherwise -> - let st1 = st { stFirstAnnouncements = Map.insert el (AnnTwo h1 h) (stFirstAnnouncements st) } - in pure (enqueueToAll (NotifyEquivProof (Just h1) h) st1) - Just (AnnTwo{}) -> pure (st, []) - -anchorVolatile :: Election -> EbHash -> St -> St -- §2 LstVolatileBody/Closure: a fresh announcement extends a held EB's elections -anchorVolatile el eh st = st - { stVolatileBody = if heldIn eh (stVolatileBody st) then addVolatile eh [el] (stVolatileBody st) else stVolatileBody st - , stVolatileClosure = if heldIn eh (stVolatileClosure st) then addVolatile eh [el] (stVolatileClosure st) else stVolatileClosure st } - -enqueueHeldOffers :: EbHash -> St -> (St, [Effect]) -- BEH-Offers · BEH-Completion: offer a held EB to peers we are announcing it to -enqueueHeldOffers eh st - | heldIn eh (stVolatileClosure st) = enqueueToAll (NotifyBlockTxsOffer eh) st - | heldIn eh (stVolatileBody st) = enqueueToAll (NotifyBlockOffer eh) st - | otherwise = (st, []) - -copyAnnIntoOfferings :: Peer -> Election -> St -> St -- BEH-Offers · §2 LstPeerOfferings -copyAnnIntoOfferings peer el st = case firstAnnouncedEb st peer el of - Just eh | offered eh -> anchorOffer peer el eh st - _ -> st - where - offered eh = isJust (EM.lookupEb eh (peerOfferingsEbm peer st)) - -anchorOffer :: Peer -> Election -> EbHash -> St -> St -- §2 LstPeerOfferings -anchorOffer peer el eh st = - case EM.activeRef <$> EM.lookupElection el perPeer of - Just act | act /= eh -> st - _ -> modifyPeerOfferings peer (\(PeerOfferings m c) -> PeerOfferings (EM.upsert eh el (Nothing, Any False) m) c) st - where - perPeer = peerOfferingsEbm peer st +----- nullIfaces :: Applicative m => Ifaces m nullIfaces = Ifaces diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md index 40e6cf793c..bfac75f985 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/SPEC-DRIFT.md @@ -100,16 +100,24 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — "New abstraction" above) — the in-memory sets of EBs whose body / full closure we hold. INVARIANT closure ⊆ body. Maintained: body added on `LevDiskDone` body-write, closure added on completion, and **a fresh first-announcement or cert extends a held EB's references** (`anchorVolatile`); **trimmed - by Promotion** (`pruneBelow` at `LevImmTipAdvanced`, now a `Slot -> Bool` predicate). `LstVolatileClosure` + at `LevImmTipAdvanced`** (`pruneBelow`, now a `Slot -> Bool` predicate). `LstVolatileClosure` is ChainSel's queryable "available complete closures" set (no disk read); `NotifyVotingAndChainSel` is the "set grew" signal. **Reconstructed from disk on startup** (`initSt`; see the Startup section) — it is the only central state rebuilt across a restart. - [ ] **`Req` dropped its `Election`** (`ReqBody EbHash bs cs | ReqJob EbHash JobId Job`); likewise `DiskWrite` (`WriteBody Body | WriteClosure EbHash [Tx]`). Spec §2 carries `el` in both. -- [ ] **`Notification`** offer ctors dropped the election (`NotifyBlockOffer EbHash` / - `NotifyBlockTxsOffer EbHash`). +- [ ] **`Notification`** offer ctors dropped the election and merged into one + **`NotifyOffer EbHash OfferLevel`** (was `NotifyBlockOffer` / `NotifyBlockTxsOffer`); the `OfferLevel` + distinguishes body vs body+closure (`offerable` / `bumpGate` take it). +- [ ] **`NotifyEquivProof RbHeader RbHeader`** carries *both* headers; the wire message keeps the optional + first header (`MsgLeiosBlockEquivocationProof (Maybe RbHeader) RbHeader`), with the omit-or-include + decision made at *send* time (see §3). - [ ] **NEW offence `RedundantOffer`** — an inbound offer that raises no LeiosNotify level disconnects (within the TTL; see §3). +- [ ] **NEW equivocation-proof offences**: `HalfEquivocationProof` (the proof omits the first header and we + have no recorded first announcement from that peer to fill it in) and `RedundantEquivProof` (the proof + *includes* a first header the peer had already announced to us — it should have omitted it). + `BogusEquivocationProof` (not a genuine equivocation) is unchanged. - [ ] **NEW parameter `envOfferDedupTtl`** (~6 h, wallclock; the `RedundantOffer` dedup epoch, kept well below the immutability window) — §2 Parameters. @@ -135,6 +143,10 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — **`dbReadClosureTxs :: EbHash -> NonEmpty Word16 -> m [Tx]`** (was `[TxHash]`), so `hServeTxs` is one DB call + a length check (no separate body read; an out-of-range position ⇒ short result ⇒ `RequestedAbsentData`). The response `MsgLeiosBlockTxs(ebHash, [Tx])` is unchanged (request-only change). +- [ ] **Removed `LevGarbageCollect` / `GarbageCollect` / `Promote`.** `DiskOp` is now just + `Write DiskWrite | RecordRef Slot EbHash`. They were trivial passthroughs: `LevImmTipAdvanced` does the + meaningful in-memory `pruneBelow` and now emits no effect, and disk-side GC/promotion is left unmodeled + (the model never simulated the disk's response to those ops anyway). ## §3 Rules @@ -166,9 +178,22 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — `LstCertified` cert (the prior check) **or** the peer's own recorded `ChainSyncSide` for that election. (Two *uncertified* announcements for one election remain ordinary equivocation — recorded via the equiv machinery, never a disconnect; an honest peer can relay producer equivocation.) -- [ ] **`LevCertValidated`**: uses `supersede` into the `EbHashMap` (and `deleteElection` when already - complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. The "already - complete?" test and the body-present anchoring now live in the Startup section below. +- [ ] **`LevBlockEquivocationProof` / `hEquivProof` + `centralEquiv`**: when the inbound proof omits the + first header it's reconstructed from the peer's recorded first announcement (`collateH1`: + `HalfEquivocationProof` if neither is available, `RedundantEquivProof` if the peer sent one we already + had). `centralEquiv` canonicalizes the stored/relayed `AnnTwo` so **our own first-announced header is + `h1`**, and `sendNotification` relays `NotifyEquivProof` with that first header dropped to `Nothing` + whenever `announcedToPeer` shows we already sent its announcement to that peer. +- [ ] **An equiv proof for an already-certified election is dropped (fetch-moot; the cert resolves it).** + `hEquivProof` drops an inbound one **silently — not a disconnect**, since the sender may simply be + behind on the cert (it rides a different channel); `centralAnnounce`'s `AnnOne→AnnTwo` branch records + `AnnTwo` but skips the relay. **TODO (Skew Fallback):** once peers offer certs, a peer that offered us + the cert and *then* sends an equiv proof for that election is provably misbehaving ⇒ disconnect. +- [ ] **`LevCertValidated`**: a `belowTip` (settled) cert is an **early-return** — no `setCertified`, + `RecordRef`, evict, or fetch (the election is past the immutable tip, and `stCertified`/refs are pruned + by exactly that condition). Otherwise it uses `supersede` into the `EbHashMap` (and `deleteElection` + when already complete); the in-place cert-switch is the EbHashMap active/inactive mechanism. The + "already complete?" test and the body-present anchoring live in the Startup section below. ## Startup / restart reconstruction (NEW — not in Spec) @@ -182,7 +207,7 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — startup). - [ ] **NEW `DiskOp` `RecordRef Slot EbHash`** — persists a first-announced / certified reference. **Fire-and-forget: it yields no `LevDiskDone`** and is not part of the persist-before-expose write - count; `GarbageCollect` prunes it by slot, `Promote` ignores it. Emitted on every **first + count; the disk reclaims it by slot. Emitted on every **first announcement** (`centralAnnounce`'s `Nothing` branch) and every **`hCertValidated`**. (These are exactly the references `stVolatile*` ever holds — `electionsNaming` yields precisely the first-announced ∪ certified elections — so persisting just these reconstructs `stVolatile*`. OK to @@ -220,8 +245,10 @@ substantially during the EbHashMap / offer-path work). Don't fix Spec.md yet — a different EB evicts the uncertified first-announcement. "Equivocate and never certify" is already handled by the note-once rule (only the first is ever retained). - [ ] **Acquire is gated by the *active* want.** `hBlock` and `hBlockTxs` only touch the cache (and persist - the closure) when the EB is some election's **active** want — new `activelyWantsEh` (active refcount - `> 0`, replacing the old `wantsEh = isJust`, which also counted an inactive/superseded ref). Without + the closure) when the EB is some election's **active** want — via `activeWantStateOf` (the want-state + iff active refcount `> 0`, one lookup that also subsumes the read of the want-state; it replaced the + separate `activelyWantsEh`, and both supersede the old `wantsEh = isJust`, which counted inactive/ + superseded refs too). Without this, a late response for a job requested *before* a cert-switch/eviction would re-acquire the dead EB's txs (and write its closure), undoing the eviction — and an adversary can time exactly that. `hBlockTxs` previously had no want-guard at all on `txCacheOnAcquire`/`WriteClosure`; `hBlock` had an diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs index 9346c4d2d3..c7188f2994 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/test/RefModelTest.hs @@ -198,15 +198,13 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "stale notification not sent" (null [ () | Send (Peer 2) _ <- fx ]) assertBool "stale notification discarded" (maybe True (Seq.null . fst) (Map.lookup (Peer 2) (stPeerNotifyQueue st1))) - , testCase "BEH-ImmTipAdvance: promote is prompt, GC is deferred" $ do - let envT = env { envImmutableTip = Slot 7 } - (_, fx) = runIdentity (step nullIfaces envT (Time 0) LevImmTipAdvanced emptySt) - assertBool "promotes slot 7" (SubmitDisk (Promote (Slot 7)) `elem` fx) - assertBool "no GC at advance" (null [ () | SubmitDisk (GarbageCollect _) <- fx ]) - - , testCase "BEH-ImmTipAdvance: a deferred LevGarbageCollect submits the disk GC" $ do - let (_, fx) = runIdentity (step nullIfaces env (Time 0) (LevGarbageCollect (Slot 7)) emptySt) - fx @?= [SubmitDisk (GarbageCollect (Slot 7))] + , testCase "BEH-ImmTipAdvance: advancing the immutable tip prunes below-tip wants" $ do + let (st0, _) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 ] + envT = env { envImmutableTip = Slot 6 } + (st1, fx) = runIdentity (step nullIfaces envT (Time 0) LevImmTipAdvanced st0) + wantStateOf st0 (EbHash 100) @?= Just (AwaitingBody 200 300) + wantStateOf st1 (EbHash 100) @?= Nothing + fx @?= [] , testCase "BEH-Wanting: a genuine equivocation is accepted; first EB stays wanted, equivocating never" $ do let (st, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 @@ -214,6 +212,29 @@ tests = testGroup "Leios RefModel — Spec.md main spec" assertBool "no disconnect" (not (any isDisconnect fx)) wantStateOf st (EbHash 100) @?= Just (AwaitingBody 200 300) + , testCase "BEH-Wanting: an equiv proof re-sending an already-announced first header disconnects" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof (Just hdr100) hdr101) ] + assertBool "disconnects with RedundantEquivProof" (Disconnect (Peer 1) RedundantEquivProof `elem` fx) + + , testCase "BEH-Wanting: an equiv proof for an already-certified election is dropped silently" $ do + let at = AnnouncementTriple el100 (HeaderHash 10) (EbHash 100) + (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 + , LevCertValidated at 200 300 + , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) ] + assertBool "no disconnect" (not (any isDisconnect fx)) + assertBool "no equiv proof relayed" (null [ () | Send _ (MsgLeiosBlockEquivocationProof _ _) <- fx ]) + + , testCase "BEH-NotifyServe: relaying an equiv proof omits a first header already announced to that peer" $ do + let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, LevPeerAdd (Peer 2) PeerSharingSampled + , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2) + , credit (Peer 2), LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) + , dequeue (Peer 2) ] + assertBool "omits the already-announced first header" + (Send (Peer 2) (MsgLeiosBlockEquivocationProof Nothing hdr101) `elem` fx) + assertBool "does not re-send the first header" + (Send (Peer 2) (MsgLeiosBlockEquivocationProof (Just hdr100) hdr101) `notElem` fx) + , testCase "BEH-Offers: an offer for an equivocating (non-first) EB disconnects" $ do let (_, fx) = run [ LevPeerAdd (Peer 1) StakeSampled, ann (Peer 1) hdr100 , LevWiredMsg (Peer 1) (MsgLeiosBlockEquivocationProof Nothing hdr101) @@ -349,7 +370,7 @@ tests = testGroup "Leios RefModel — Spec.md main spec" , credit (Peer 2), ann (Peer 1) hdr100, dequeue (Peer 2), credit (Peer 2) , LevDiskDone (WriteBody body100) ] q = maybe Seq.empty fst (Map.lookup (Peer 2) (stPeerNotifyQueue st)) - assertBool "body offer enqueued" (NotifyBlockOffer (EbHash 100) `elem` q) + assertBool "body offer enqueued" (NotifyOffer (EbHash 100) OfferBody `elem` q) , testCase "BEH-Completion: voting + ChainSel are notified only when the last write lands (persist-gated)" $ do let txs = [Tx (TxHash 1) 150, Tx (TxHash 2) 150] From 03144588de7cec6a102785ccc6522f9ad83ef6de Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 30 Jun 2026 05:04:58 -0400 Subject: [PATCH 15/16] WIP add TODOs for some complexity to backout (multiple "levels" of spec to maintain) --- .../Test/Leios/RefModel/RefModel.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 1f8ccc342e..427e961b42 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -187,6 +187,9 @@ data PeerOfferings = -- §2 LstPeerOfferings (offer levels; per-election ChainS (Election :-> ChainSyncSide) deriving (Eq, Show) +-- TODO as a simpler starting point, replace EbHashMap a with Map Election a +-- Check the stVolatileDb to avoid fetching an EB body you already have, but don't dedup beyond that. +-- In particular, Msg*Offer identifies _the election_ instead of the SlotNo-EbHash pair. data St = St { stFirstAnnouncements :: !(Election :-> AnnState) -- §2 LstFirstAnnouncements , stPeerFirstAnnouncements :: !(Peer :-> Election :-> AnnSeen) -- §2 LstPeerFirstAnnouncements @@ -263,6 +266,8 @@ belowTip env el = electionSlot el < envImmutableTip env data DbKey = DbBody EbHash | DbClosureTx EbHash TxHash -- §2 dbQueryPresent keys deriving (Eq, Ord, Show) +-- TODO as a simpler starting point, don't model this as IO; just specify the entire thing as if it were to live in-memory, like any other piece of Leios state +-- Use a newtype Disk x = Disk x wrapper to highlight just the data that's too big to actually be in memory. data LeiosDb m = LeiosDb -- §2 disk store interface { dbQueryPresent :: Set DbKey -> m (Set DbKey) -- BEH-Completion / BEH-FetchServe , dbReadBody :: EbHash -> m (Maybe Body) -- BEH-Completion @@ -270,6 +275,8 @@ data LeiosDb m = LeiosDb -- §2 disk store interface , dbReadAllRefs :: m [(Slot, EbHash)] -- BEH-Startup (first-announced/certified references; reconstruct stVolatile*) } +-- TODO as a simpler starting point, don't model this as IO; just specify the entire thing as if it were to live in-memory, like any other piece of Leios state +-- Use a newtype Disk x = Disk x wrapper to highlight just the data that's too big to actually be in memory. data TxCache m = TxCache -- §7 TxCache hooks { txCacheNoteAnnouncement :: Election -> EbHash -> m () -- BEH-Wanting , txCacheEvictForValidCert :: Election -> EbHash -> m () -- BEH-Wanting From 3530598a7f5afc1fbfe1cf030a74397f81164a2f Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Tue, 30 Jun 2026 05:05:19 -0400 Subject: [PATCH 16/16] WIP add TODO about replacing MsgLeiosBlockOffer with MsgLeiosOfferPreRequest --- .../Test/Leios/RefModel/RefModel.hs | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs index 427e961b42..c3cd9e2ed7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Leios/RefModel/RefModel.hs @@ -290,6 +290,37 @@ data Mempool m = Mempool -- §2 Reads of un-owned sta data Ifaces m = Ifaces { ifDb :: LeiosDb m, ifTxc :: TxCache m, ifMem :: Mempool m } +-- TODO consider having the decision logic send body requests to +-- upstream peers that agree with us on the first-announcement for +-- some election without waiting for them to offer the body. +-- +-- PRO: saves 0.5 RTT latency, by not waiting for offer (That doesn't +-- actually add up to saving 1 RTT for body+closure, b/c body relay +-- doesn't wait for closure.) +-- +-- EQUAL: if we're always requesting everything from everyone anyway, +-- there's no lost opportunities here +-- +-- CON: it's convenient/"simpler" for the same flow/steps/phases/etc +-- to be as similar as possible for bodies and closures. (TODO I +-- suppose we could do this for closures too: if they already got the +-- body from someone else, they could plausibly pre-request txs from +-- us even before we have the body... but it's harder to bound how +-- many _closure_ requests we'd have to remember... maybe we crudely +-- limit it to at most 10 requests per election? and they have to wait +-- for us to issue replies before sending more ... and now we have to +-- send MsgLeiosBlockNeverAcquired for requests if the announcement +-- ages out before we receive its body) +-- +-- CON: but if we're doing any Staggered Requests, etc, then our +-- _first requests_ are mere guesses instead of being sent only to the +-- first peers that claim to be ready (slow-loris can lie either way, +-- but consider the all honest case) +-- +-- EQUAL: instead of tracking offer-gates for each downstream peer, +-- we'd instead track which requests they've sent (DoS mitigation: we +-- disconnect when a downstream peer requests data for an election +-- that we haven't relayed (TODO how to handle LevCertValidated?)) data WireMsg -- §2 Wire messages = MsgLeiosNotificationRequestNext | MsgLeiosBlockAnnouncement RbHeader