From c087cf45044f5b160cf604b1303591404c73aca4 Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:06:45 +0100 Subject: [PATCH 01/12] Add Lean disaster recovery transition model Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/.gitignore | 1 + lean/disaster-recovery/DisasterRecovery.lean | 1 + .../DisasterRecovery/Protocol/Model.lean | 290 ++++++++++++++++++ lean/disaster-recovery/lake-manifest.json | 116 +++++++ lean/disaster-recovery/lakefile.toml | 14 + lean/disaster-recovery/lean-toolchain | 1 + 6 files changed, 423 insertions(+) create mode 100644 lean/disaster-recovery/.gitignore create mode 100644 lean/disaster-recovery/DisasterRecovery.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Model.lean create mode 100644 lean/disaster-recovery/lake-manifest.json create mode 100644 lean/disaster-recovery/lakefile.toml create mode 100644 lean/disaster-recovery/lean-toolchain diff --git a/lean/disaster-recovery/.gitignore b/lean/disaster-recovery/.gitignore new file mode 100644 index 00000000000..4080d07dfc3 --- /dev/null +++ b/lean/disaster-recovery/.gitignore @@ -0,0 +1 @@ +/.lake/ diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean new file mode 100644 index 00000000000..18d54a2a49b --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -0,0 +1 @@ +import DisasterRecovery.Protocol.Model diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Model.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Model.lean new file mode 100644 index 00000000000..323e79f08c1 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Model.lean @@ -0,0 +1,290 @@ +import Std + +namespace DisasterRecovery.Protocol + +abbrev Location := String + +structure TxID where + view : Nat + seqno : Nat +deriving Repr, BEq, ReflBEq, LawfulBEq, Hashable, Inhabited, DecidableEq + +inductive Phase where + | gossiping + | voting + | opening + | joining + | open +deriving Repr, BEq, ReflBEq, LawfulBEq, Hashable, Inhabited, DecidableEq + +inductive OpenKind where + | quorum + | failover +deriving Repr, BEq, ReflBEq, LawfulBEq, Hashable, Inhabited, DecidableEq + +inductive Validation where + | accepted + | rejected +deriving Repr, BEq, Hashable, Inhabited, DecidableEq + +structure Config where + instanceId : String + expectedLocations : List Location +deriving Repr, BEq, Hashable, Inhabited + +def Config.isValid (config : Config) : Bool := + !config.instanceId.isEmpty && + !config.expectedLocations.isEmpty && + !config.expectedLocations.any String.isEmpty && + config.expectedLocations.eraseDups.length = + config.expectedLocations.length + +structure NodeState where + location : Location + phase : Phase := .gossiping + timeoutState : Phase := .gossiping + gossips : List (Prod Location TxID) := [] + votes : List Location := [] + chosen : Option Location := none + openKind : Option OpenKind := none + restartRequested : Bool := false +deriving Repr, BEq, ReflBEq, LawfulBEq, Hashable, Inhabited + +inductive Event where + | receiveGossip (source : Location) (txid : TxID) (validation : Validation) + | receiveVote (source : Location) (validation : Validation) + | receiveIAmOpen (source : Location) (validation : Validation) + | timeout + | retry +deriving Repr, BEq, Hashable + +inductive Effect where + | sendGossip (destination : Location) + | sendVote (destination : Location) + | sendIAmOpen (destination : Location) + | opening (kind : OpenKind) + | restart (chosen : Location) + | completed + | rejected (reason : String) +deriving Repr, BEq, Hashable + +structure StepOutput where + state : NodeState + effects : List Effect := [] + accepted : Bool := true +deriving Repr, BEq, Inhabited + +structure SystemState where + nodes : List (Prod Location NodeState) +deriving Repr, BEq, Hashable, Inhabited + +def phaseName : Phase -> String + | .gossiping => "GOSSIPING" + | .voting => "VOTING" + | .opening => "OPENING" + | .joining => "JOINING" + | .open => "OPEN" + +def openKindName : OpenKind -> String + | .quorum => "QUORUM" + | .failover => "FAILOVER" + +def initialNode (location : Location) : NodeState := + { location } + +def initialSystem (config : Config) : SystemState := + { nodes := config.expectedLocations.map fun location => + (location, initialNode location) } + +def voteQuorum (config : Config) : Nat := + config.expectedLocations.length / 2 + 1 + +def validTimeout (state : NodeState) (timeout : Bool) : Bool := + timeout && decide (state.phase = state.timeoutState) + +def txScoreGreater + (leftName : Location) + (left : TxID) + (rightName : Location) + (right : TxID) : Bool := + right.view < left.view || + (right.view == left.view && + (right.seqno < left.seqno || + (right.seqno == left.seqno && rightName < leftName))) + +def selectMaximum + (current candidate : Prod Location TxID) : + Prod Location TxID := + if txScoreGreater candidate.1 candidate.2 current.1 current.2 then + candidate + else + current + +def maximumGossip : List (Prod Location TxID) -> Option (Prod Location TxID) + | [] => none + | head :: tail => + some (tail.foldl selectMaximum head) + +def insertGossip + (source : Location) + (txid : TxID) + (gossips : List (Prod Location TxID)) : + List (Prod Location TxID) := + if gossips.any (fun entry => entry.1 == source) then + gossips + else + ((source, txid) :: gossips).mergeSort (fun left right => left.1 <= right.1) + +def insertVote (source : Location) (votes : List Location) : List Location := + if votes.contains source then votes + else (source :: votes).mergeSort (fun left right => left <= right) + +def advanceTimeoutState : Phase -> Phase + | .gossiping => .voting + | .voting => .opening + | state => state + +def advanceTimeoutLane (state : NodeState) (timeout : Bool) : NodeState := + if timeout then + { state with timeoutState := advanceTimeoutState state.timeoutState } + else + state + +def advance (config : Config) (state : NodeState) (timeout : Bool) : + Option StepOutput := + let aligned := validTimeout state timeout + match state.phase with + | .gossiping => + if decide (state.gossips.length >= config.expectedLocations.length) || aligned then + match maximumGossip state.gossips with + | none => none + | some (chosen, _) => + let next := { state with phase := .voting, chosen := some chosen } + some { state := advanceTimeoutLane next timeout } + else + some { state := advanceTimeoutLane state timeout } + | .voting => + let sufficient := decide (state.votes.length >= voteQuorum config) + if sufficient || aligned then + if aligned && state.votes.isEmpty then + some { state } + else + let kind := if aligned && !sufficient then .failover else .quorum + let next := { + state with + phase := .opening + openKind := some kind + } + some { + state := advanceTimeoutLane next timeout + effects := [.opening kind] + } + else + some { state := advanceTimeoutLane state timeout } + | .joining => + match state.chosen with + | none => none + | some chosen => + some { + state := advanceTimeoutLane + { state with restartRequested := true } timeout + effects := [.restart chosen] + } + | .opening => + if aligned then + some { + state := advanceTimeoutLane { state with phase := .open } timeout + effects := [.completed] + } + else + some { state := advanceTimeoutLane state timeout } + | .open => + some { state := advanceTimeoutLane state timeout } + +def rejected (state : NodeState) (reason : String) : StepOutput := + { state, effects := [.rejected reason], accepted := false } + +def step (config : Config) (state : NodeState) : Event -> StepOutput + | .receiveGossip source txid validation => + match validation with + | .rejected => rejected state "quote-or-certificate" + | .accepted => + if state.chosen != none then + rejected state "gossip-frozen" + else + let received := { state with + gossips := insertGossip source txid state.gossips } + (advance config received false).getD + (rejected state "empty-gossip-advance") + | .receiveVote source validation => + match validation with + | .rejected => rejected state "quote-or-certificate" + | .accepted => + let received := { state with votes := insertVote source state.votes } + (advance config received false).getD + (rejected state "vote-advance") + | .receiveIAmOpen source validation => + match validation with + | .rejected => rejected state "quote-or-certificate" + | .accepted => + match state.phase with + | .opening | .open => + rejected state "already-opening-or-open" + | _ => + let received := { + state with + phase := .joining + chosen := some source + } + (advance config received false).getD + (rejected state "join-without-chosen") + | .timeout => + (advance config state true).getD + (rejected state "empty-gossip-timeout-aborts") + | .retry => + let effects := + match state.phase with + | .gossiping => + config.expectedLocations.map .sendGossip + | .voting => + match state.chosen with + | none => config.expectedLocations.map .sendGossip + | some chosen => + .sendVote chosen :: config.expectedLocations.map .sendGossip + | .opening => + (config.expectedLocations.filter + (fun location => location != state.location)).map .sendIAmOpen + | .joining | .open => [] + { state, effects } + +def replaceNode + (target : Location) + (next : NodeState) + (nodes : List (Prod Location NodeState)) : + List (Prod Location NodeState) := + nodes.map fun entry => if entry.1 == target then (target, next) else entry + +def systemStep + (config : Config) + (state : SystemState) + (target : Location) + (event : Event) : + Option (Prod SystemState StepOutput) := do + let node <- (state.nodes.find? fun entry => entry.1 == target).map Prod.snd + let output := step config node event + pure ({ + nodes := replaceNode target output.state state.nodes + }, output) + +def expectedSource (config : Config) (source : Location) : Bool := + config.expectedLocations.contains source + +def stateKey (state : NodeState) : String := + let gossips := String.intercalate "," (state.gossips.map fun entry => + s!"{entry.1}@{entry.2.view}.{entry.2.seqno}") + let votes := String.intercalate "," state.votes + let chosen := state.chosen.getD "-" + let kind := state.openKind.map openKindName |>.getD "-" + s!"{state.location}|{phaseName state.phase}|{phaseName state.timeoutState}|g={gossips}|v={votes}|c={chosen}|k={kind}|r={state.restartRequested}" + +end DisasterRecovery.Protocol diff --git a/lean/disaster-recovery/lake-manifest.json b/lean/disaster-recovery/lake-manifest.json new file mode 100644 index 00000000000..4df3dace4b3 --- /dev/null +++ b/lean/disaster-recovery/lake-manifest.json @@ -0,0 +1,116 @@ +{ + "version": "1.1.0", + "packagesDir": ".lake/packages", + "packages": [ + { + "url": "https://github.com/leanprover-community/mathlib4.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "8f9d9cff6bd728b17a24e163c9402775d9e6a365", + "name": "mathlib", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.28.0", + "inherited": false, + "configFile": "lakefile.lean" + }, + { + "url": "https://github.com/leanprover-community/plausible", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "55c8532eb21ec9f6d565d51d96b8ca50bd1fbef3", + "name": "plausible", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover-community/LeanSearchClient", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "c5d5b8fe6e5158def25cd28eb94e4141ad97c843", + "name": "LeanSearchClient", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover-community/import-graph", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "85b59af46828c029a9168f2f9c35119bd0721e6e", + "name": "importGraph", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover-community/ProofWidgets4", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "be3b2e63b1bbf496c478cef98b86972a37c1417d", + "name": "proofwidgets", + "manifestFile": "lake-manifest.json", + "inputRev": "v0.0.87", + "inherited": true, + "configFile": "lakefile.lean" + }, + { + "url": "https://github.com/leanprover-community/aesop", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "f642a64c76df8ba9cb53dba3b919425a0c2aeaf1", + "name": "aesop", + "manifestFile": "lake-manifest.json", + "inputRev": "master", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover-community/quote4", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "b8f98e9087e02c8553945a2c5abf07cec8e798c3", + "name": "Qq", + "manifestFile": "lake-manifest.json", + "inputRev": "master", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover-community/batteries", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "495c008c3e3f4fb4256ff5582ddb3abf3198026f", + "name": "batteries", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml" + }, + { + "url": "https://github.com/leanprover/lean4-cli", + "type": "git", + "subDir": null, + "scope": "leanprover", + "rev": "4f10f47646cb7d5748d6f423f4a07f98f7bbcc9e", + "name": "Cli", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.28.0", + "inherited": true, + "configFile": "lakefile.toml" + } + ], + "name": "disaster_recovery", + "lakeDir": ".lake" +} diff --git a/lean/disaster-recovery/lakefile.toml b/lean/disaster-recovery/lakefile.toml new file mode 100644 index 00000000000..df0456dcd8c --- /dev/null +++ b/lean/disaster-recovery/lakefile.toml @@ -0,0 +1,14 @@ +name = "disaster_recovery" +version = "0.1.0" +moreLeanArgs = ["-DwarningAsError=true"] +defaultTargets = [ + "DisasterRecovery", +] + +[[require]] +name = "mathlib" +git = "https://github.com/leanprover-community/mathlib4.git" +rev = "v4.28.0" + +[[lean_lib]] +name = "DisasterRecovery" diff --git a/lean/disaster-recovery/lean-toolchain b/lean/disaster-recovery/lean-toolchain new file mode 100644 index 00000000000..4c685fa085f --- /dev/null +++ b/lean/disaster-recovery/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.28.0 From 3fa47361378ae0c1484b8af4020afccbe080c2d3 Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:06:56 +0100 Subject: [PATCH 02/12] Prove local recovery safety and liveness Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/DisasterRecovery.lean | 1 + .../DisasterRecovery/Protocol/Temporal.lean | 231 ++++++++++++++++++ 2 files changed, 232 insertions(+) create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean index 18d54a2a49b..7fc1d3ad48a 100644 --- a/lean/disaster-recovery/DisasterRecovery.lean +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -1 +1,2 @@ import DisasterRecovery.Protocol.Model +import DisasterRecovery.Protocol.Temporal diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean new file mode 100644 index 00000000000..72db88bcbc0 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean @@ -0,0 +1,231 @@ +import DisasterRecovery.Protocol.Model + +namespace DisasterRecovery.Protocol + +def EventuallyFrom (start : Nat) (predicate : Nat -> Prop) : Prop := + exists n, start <= n /\ predicate n + +def AlwaysFrom (start : Nat) (predicate : Nat -> Prop) : Prop := + forall n, start <= n -> predicate n + +def InfinitelyOften (predicate : Nat -> Prop) : Prop := + forall start, EventuallyFrom start predicate + +def EventuallyAlways (predicate : Nat -> Prop) : Prop := + exists start, AlwaysFrom start predicate + +structure Execution (config : Config) where + states : Nat -> NodeState + events : Nat -> Event + step_succ : forall n, + states (n + 1) = (step config (states n) (events n)).state + +def WeakFairness + {config : Config} + (execution : Execution config) + (enabled : NodeState -> Prop) + (fired : NodeState -> Event -> Prop) : Prop := + forall start, + AlwaysFrom start (fun n => enabled (execution.states n)) -> + EventuallyFrom start + (fun n => fired (execution.states n) (execution.events n)) + +def StrongFairness + {config : Config} + (execution : Execution config) + (enabled : NodeState -> Prop) + (fired : NodeState -> Event -> Prop) : Prop := + InfinitelyOften (fun n => enabled (execution.states n)) -> + InfinitelyOften + (fun n => fired (execution.states n) (execution.events n)) + +def AlignedOpening (state : NodeState) : Prop := + state.phase = .opening /\ state.timeoutState = .opening + +theorem valid_timeout_requires_alignment + (state : NodeState) + (h : validTimeout state true = true) : + state.phase = state.timeoutState := by + simpa [validTimeout] using h + +theorem gossip_freezes_after_choice + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) + (h : state.chosen.isSome = true) : + let output := step config state (.receiveGossip source txid .accepted) + output.state = state /\ output.accepted = false := by + cases chosen : state.chosen <;> simp_all [step, rejected] + +theorem rejected_gossip_stutters + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) : + let output := step config state (.receiveGossip source txid .rejected) + output.state = state /\ output.accepted = false := by + simp [step, rejected] + +theorem duplicate_vote_is_idempotent + (source : Location) + (votes : List Location) + (h : votes.contains source = true) : + insertVote source votes = votes := by + unfold insertVote + rw [h] + simp + +theorem opening_rejects_iamopen + (config : Config) + (state : NodeState) + (source : Location) : + let opening := { state with phase := .opening } + let output := step config opening (.receiveIAmOpen source .accepted) + output.state = opening /\ output.accepted = false := by + simp [step, rejected] + +theorem open_rejects_iamopen + (config : Config) + (state : NodeState) + (source : Location) : + let opened := { state with phase := .open } + let output := step config opened (.receiveIAmOpen source .accepted) + output.state = opened /\ output.accepted = false := by + simp [step, rejected] + +theorem aligned_voting_timeout_without_votes_stutters + (config : Config) + (state : NodeState) : + let waiting := { + state with + phase := .voting + timeoutState := .voting + votes := [] + } + step config waiting .timeout = { state := waiting } := by + simp [step, advance, validTimeout, voteQuorum] + +theorem aligned_opening_timeout_completes + (config : Config) + (state : NodeState) : + let opening := { + state with + phase := .opening + timeoutState := .opening + } + let output := step config opening .timeout + output.state.phase = .open /\ + output.state.timeoutState = .opening /\ + output.effects = [.completed] := by + simp [step, advance, validTimeout, advanceTimeoutLane, advanceTimeoutState] + +theorem quorum_advance_opens + (config : Config) + (state : NodeState) + (phase : state.phase = .voting) + (quorum : state.votes.length >= voteQuorum config) : + let output := (advance config state false).get! + output.state.phase = .opening /\ + output.state.openKind = some .quorum /\ + output.effects = [.opening .quorum] := by + simp [advance, phase, quorum, validTimeout, advanceTimeoutLane] + +theorem aligned_empty_gossip_timeout_aborts + (config : Config) + (state : NodeState) : + let waiting := { + state with + phase := .gossiping + timeoutState := .gossiping + gossips := [] + } + let output := step config waiting .timeout + output.state = waiting /\ output.accepted = false := by + simp [step, advance, validTimeout, rejected, maximumGossip] + +theorem non_timeout_step_preserves_aligned_opening + (config : Config) + (state : NodeState) + (event : Event) + (aligned : AlignedOpening state) + (notTimeout : Not (event = .timeout)) : + AlignedOpening (step config state event).state := by + have phase := aligned.1 + have timeoutState := aligned.2 + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected, advance, validTimeout, + advanceTimeoutLane] + split <;> simp_all + | receiveVote source validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected] + | timeout => + exact (notTimeout rfl).elim + | retry => + simp [AlignedOpening, step, phase, timeoutState] + +theorem aligned_timeout_transitions_to_open + (config : Config) + (state : NodeState) + (aligned : AlignedOpening state) : + (step config state .timeout).state.phase = .open := by + have phase := aligned.1 + have timeoutState := aligned.2 + simp [step, advance, validTimeout, phase, timeoutState, + advanceTimeoutLane, advanceTimeoutState] + +theorem fairness_supplies_firing + {config : Config} + (execution : Execution config) + (enabled : NodeState -> Prop) + (fired : NodeState -> Event -> Prop) + (fair : WeakFairness execution enabled fired) + (alwaysEnabled : forall n, enabled (execution.states n)) : + InfinitelyOften + (fun n => fired (execution.states n) (execution.events n)) := by + intro start + exact fair start (fun n _ => alwaysEnabled n) + +theorem fair_aligned_opening_progress + {config : Config} + (execution : Execution config) + (initial : AlignedOpening (execution.states 0)) + (fair : WeakFairness execution AlignedOpening + (fun _ event => event = .timeout)) : + EventuallyFrom 0 + (fun n => (execution.states n).phase = .open) := by + apply Classical.byContradiction + intro noOpen + have neverOpen : + forall n, Not ((execution.states n).phase = .open) := by + intro n opened + apply noOpen + exact Exists.intro n (And.intro (Nat.zero_le n) opened) + have alignedAlways : forall n, AlignedOpening (execution.states n) := by + intro n + induction n with + | zero => exact initial + | succ n aligned => + have notTimeout : Not (execution.events n = .timeout) := by + intro timeout + apply neverOpen (n + 1) + rw [execution.step_succ n, timeout] + exact aligned_timeout_transitions_to_open config _ aligned + rw [execution.step_succ n] + exact non_timeout_step_preserves_aligned_opening + config _ _ aligned notTimeout + have firing := fair 0 (fun n _ => alignedAlways n) + let n := firing.choose + have timeout := firing.choose_spec.2 + apply neverOpen (n + 1) + rw [execution.step_succ n, timeout] + exact aligned_timeout_transitions_to_open config _ (alignedAlways n) + +end DisasterRecovery.Protocol \ No newline at end of file From 6f5f0ff88b29c0568ece1f59fcc851717ec6a525 Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:07:08 +0100 Subject: [PATCH 03/12] Add global recovery semantics and invariants Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/DisasterRecovery.lean | 2 + .../DisasterRecovery/Protocol/Global.lean | 166 ++++ .../DisasterRecovery/Protocol/Invariants.lean | 899 ++++++++++++++++++ 3 files changed, 1067 insertions(+) create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean index 7fc1d3ad48a..c20571142be 100644 --- a/lean/disaster-recovery/DisasterRecovery.lean +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -1,2 +1,4 @@ import DisasterRecovery.Protocol.Model import DisasterRecovery.Protocol.Temporal +import DisasterRecovery.Protocol.Global +import DisasterRecovery.Protocol.Invariants diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean new file mode 100644 index 00000000000..c29b83a1305 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean @@ -0,0 +1,166 @@ +import DisasterRecovery.Protocol.Model + +namespace DisasterRecovery.Protocol.Global + +structure Config where + protocol : Protocol.Config + recovered : List (Prod Location TxID) +deriving Repr, BEq + +def Config.Valid (config : Config) : Prop := + config.protocol.isValid = true /\ + config.protocol.expectedLocations.Nodup /\ + config.recovered.map Prod.fst = config.protocol.expectedLocations + +def recoveredTxID (config : Config) (source : Location) : Option TxID := + (config.recovered.find? fun entry => entry.1 == source).map Prod.snd + +inductive Payload where + | gossip (txid : TxID) + | vote + | iAmOpen +deriving Repr, BEq, ReflBEq, LawfulBEq + +structure Envelope where + source : Location + target : Location + payload : Payload + sourceState : NodeState +deriving Repr, BEq, ReflBEq, LawfulBEq + +structure Opening where + node : Location + kind : OpenKind + state : NodeState +deriving Repr, BEq + +structure State where + system : SystemState + active : List Location + network : List Envelope := [] + sent : List Envelope := [] + openings : List Opening := [] + restarts : List Location := [] + completed : List Location := [] +deriving Repr, BEq + +inductive Action where + | retry (source : Location) + | deliver (envelope : Envelope) + | timeout (target : Location) +deriving Repr, BEq + +def nodeState (state : State) (node : Location) : Option NodeState := + (state.system.nodes.find? fun entry => entry.1 == node).map Prod.snd + +def messageForEffect + (config : Config) + (source : Location) + (sourceState : NodeState) : Effect -> Option Envelope + | .sendGossip target => do + let txid <- recoveredTxID config source + pure { source, target, payload := .gossip txid, sourceState } + | .sendVote target => + some { source, target, payload := .vote, sourceState } + | .sendIAmOpen target => + some { source, target, payload := .iAmOpen, sourceState } + | _ => none + +def retryMessages + (config : Config) + (source : Location) + (sourceState : NodeState) : List Envelope := + (step config.protocol sourceState .retry).effects.filterMap + (messageForEffect config source sourceState) + +def Envelope.Valid (config : Config) (envelope : Envelope) : Prop := + envelope.sourceState.location = envelope.source /\ + envelope ∈ retryMessages config envelope.source envelope.sourceState + +def eventFor (envelope : Envelope) : Event := + match envelope.payload with + | .gossip txid => .receiveGossip envelope.source txid .accepted + | .vote => .receiveVote envelope.source .accepted + | .iAmOpen => .receiveIAmOpen envelope.source .accepted + +def removeOne [BEq α] (value : α) : List α -> List α + | [] => [] + | head :: tail => + if head == value then tail else head :: removeOne value tail + +def recordEffect + (node : Location) + (nodeState : NodeState) + (state : State) : Effect -> State + | .opening kind => + { + state with + openings := { node, kind, state := nodeState } :: state.openings + } + | .restart _ => + { state with restarts := node :: state.restarts } + | .completed => + { state with completed := node :: state.completed } + | _ => state + +def recordEffects + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : State := + effects.foldl (recordEffect node nodeState) state + +def initial (config : Config) (active : List Location) : State := { + system := initialSystem config.protocol + active +} + +def next (config : Config) (state : State) : Action -> Option State + | .retry source => do + guard (state.active.contains source) + let sourceState <- nodeState state source + let messages := retryMessages config source sourceState + guard (!messages.isEmpty) + pure { + state with + network := state.network ++ messages + sent := state.sent ++ messages + } + | .deliver envelope => do + guard (state.network.contains envelope) + guard (state.active.contains envelope.target) + let (system, output) <- + systemStep config.protocol state.system envelope.target + (eventFor envelope) + let delivered := { + state with + system + network := removeOne envelope state.network + } + pure + (recordEffects envelope.target output.state output.effects delivered) + | .timeout target => do + guard (state.active.contains target) + let (system, output) <- + systemStep config.protocol state.system target .timeout + guard output.accepted + pure + (recordEffects target output.state output.effects { state with system }) + +inductive Reachable (config : Config) : State -> Prop where + | initial + (active : List Location) + (valid : config.Valid) + (nodup : active.Nodup) + (configured : + forall node, node ∈ active -> + node ∈ config.protocol.expectedLocations) : + Reachable config (Global.initial config active) + | step + {state nextState : State} + {action : Action} + (reachable : Reachable config state) + (transition : next config state action = some nextState) : + Reachable config nextState + +end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean new file mode 100644 index 00000000000..3fa11e0bcdd --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean @@ -0,0 +1,899 @@ +import DisasterRecovery.Protocol.Global +import Mathlib.Tactic + +namespace DisasterRecovery.Protocol.Global + +structure HistoriesActive (state : State) : Prop where + openings : + forall opening, opening ∈ state.openings -> + opening.node ∈ state.active + restarts : + forall node, node ∈ state.restarts -> + node ∈ state.active + completed : + forall node, node ∈ state.completed -> + node ∈ state.active + +structure WellFormed (config : Config) (state : State) : Prop where + nodeKeys : + state.system.nodes.map Prod.fst = + config.protocol.expectedLocations + nodeKeysNodup : (state.system.nodes.map Prod.fst).Nodup + nodeLocations : + forall entry, entry ∈ state.system.nodes -> + entry.2.location = entry.1 + activeNodup : state.active.Nodup + activeConfigured : + forall node, node ∈ state.active -> + node ∈ config.protocol.expectedLocations + sentValid : + forall envelope, envelope ∈ state.sent -> + envelope.Valid config + sentSourceActive : + forall envelope, envelope ∈ state.sent -> + envelope.source ∈ state.active + networkSent : + forall envelope, envelope ∈ state.network -> + envelope ∈ state.sent + historiesActive : HistoriesActive state + +theorem messageForEffect_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {effect : Effect} + {envelope : Envelope} + (created : + messageForEffect config source sourceState effect = some envelope) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + cases effect with + | sendGossip target => + cases found : recoveredTxID config source with + | none => + simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendVote target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | opening kind => + simp_all [messageForEffect] + | restart chosen => + simp_all [messageForEffect] + | completed => + simp_all [messageForEffect] + | rejected reason => + simp_all [messageForEffect] + +theorem retryMessages_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {envelope : Envelope} + (created : + envelope ∈ retryMessages config source sourceState) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + rw [retryMessages, List.mem_filterMap] at created + rcases created with ⟨effect, _, produced⟩ + exact messageForEffect_source produced + +theorem retryMessages_valid + (config : Config) + (source : Location) + (sourceState : NodeState) + (sourceLocation : sourceState.location = source) : + forall envelope, + envelope ∈ retryMessages config source sourceState -> + envelope.Valid config := by + intro envelope created + rcases retryMessages_source created with + ⟨sourceEq, stateEq⟩ + constructor + · rw [stateEq, sourceEq] + exact sourceLocation + · rw [sourceEq, stateEq] + exact created + +theorem valid_envelope_effect + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) : + exists effect, + effect ∈ + (step config.protocol envelope.sourceState .retry).effects /\ + messageForEffect config envelope.source + envelope.sourceState effect = some envelope := by + rcases valid with ⟨_, created⟩ + rw [retryMessages, List.mem_filterMap] at created + exact created + +theorem valid_gossip_uses_recovered_txid + {config : Config} + {envelope : Envelope} + {txid : TxID} + (valid : envelope.Valid config) + (gossip : envelope.payload = .gossip txid) : + recoveredTxID config envelope.source = some txid := by + rcases valid_envelope_effect valid with + ⟨effect, _, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => + simp [messageForEffect, found] at created + | some recovered => + simp [messageForEffect, found] at created + rw [←created] at gossip + injection gossip with same + subst recovered + rfl + | sendVote target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | opening kind => + simp [messageForEffect] at created + | restart chosen => + simp [messageForEffect] at created + | completed => + simp [messageForEffect] at created + | rejected reason => + simp [messageForEffect] at created + +theorem step_preserves_location + (config : Protocol.Config) + (state : NodeState) + (event : Event) : + (step config state event).state.location = state.location := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +theorem nodeState_location + {state : State} + {node : Location} + {foundState : NodeState} + (locations : + forall entry, entry ∈ state.system.nodes -> + entry.2.location = entry.1) + (found : nodeState state node = some foundState) : + foundState.location = node := by + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have membership : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some findEq + have condition : (entry.1 == node) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq + have keyEq : entry.1 = node := beq_iff_eq.mp condition + rw [←stateEq, locations entry membership, keyEq] + +theorem initial_well_formed + (config : Config) + (active : List Location) + (valid : config.Valid) + (activeNodup : active.Nodup) + (activeConfigured : + forall node, node ∈ active -> + node ∈ config.protocol.expectedLocations) : + WellFormed config (initial config active) := by + constructor + · simp [Global.initial, initialSystem, Function.comp_def] + · simpa [Global.initial, initialSystem, Function.comp_def] using valid.2.1 + · simp [Global.initial, initialSystem, initialNode] + · exact activeNodup + · exact activeConfigured + · simp [Global.initial] + · simp [Global.initial] + · simp [Global.initial] + · constructor <;> simp [Global.initial] + +@[simp] +theorem recordEffects_active + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).active = state.active := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).active = + state.active + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_system + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).system = state.system := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).system = + state.system + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_network + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).network = state.network := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).network = + state.network + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_sent + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).sent = state.sent := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).sent = + state.sent + rw [ih] + cases effect <;> rfl + +theorem recordEffect_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffect node nodeState state effect) := by + rcases wellFormed with ⟨openings, restarts, completed⟩ + cases effect <;> + constructor <;> + simp_all [recordEffect] + +theorem recordEffects_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffects node nodeState effects state) := by + induction effects generalizing state with + | nil => exact wellFormed + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + apply ih + · exact recordEffect_preserves_histories_active wellFormed nodeActive + · cases effect <;> simpa [recordEffect] using nodeActive + +theorem mem_of_mem_removeOne + [BEq α] + (value member : α) + (values : List α) : + member ∈ removeOne value values -> + member ∈ values := by + induction values with + | nil => simp [removeOne] + | cons head tail ih => + simp only [removeOne] + split + · exact List.mem_cons_of_mem head + · intro membership + rw [List.mem_cons] at membership ⊢ + exact membership.imp_right ih + +theorem mem_openings_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffect node nodeState state effect).openings := by + cases effect <;> simp_all [recordEffect] + +theorem mem_restarts_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffect node nodeState state effect).restarts := by + cases effect <;> simp_all [recordEffect] + +theorem mem_completed_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffect node nodeState state effect).completed := by + cases effect <;> simp_all [recordEffect] + +theorem mem_openings_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffects node nodeState effects state).openings := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_openings_recordEffect membership) + +theorem mem_restarts_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffects node nodeState effects state).restarts := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_restarts_recordEffect membership) + +theorem mem_completed_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffects node nodeState effects state).completed := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_completed_recordEffect membership) + +theorem replaceNode_keys + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) : + (replaceNode target nextState nodes).map Prod.fst = + nodes.map Prod.fst := by + induction nodes with + | nil => rfl + | cons entry tail ih => + simp only [replaceNode, List.map_cons] + split + · + rename_i condition + have same : entry.1 = target := beq_iff_eq.mp condition + simp only [List.cons.injEq] + constructor + · exact same.symm + · simpa [replaceNode] using ih + · + simp only [List.cons.injEq, true_and] + simpa [replaceNode] using ih + +theorem replaceNode_locations + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (locations : + forall entry, entry ∈ nodes -> + entry.2.location = entry.1) + (nextLocation : nextState.location = target) : + forall entry, entry ∈ replaceNode target nextState nodes -> + entry.2.location = entry.1 := by + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · exact nextLocation + · exact locations previous previousMember + +theorem findNode_replaceNode_ne + (target other : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (different : other ≠ target) : + ((replaceNode target nextState nodes).find? + fun entry => entry.1 == other).map Prod.snd = + (nodes.find? fun entry => entry.1 == other).map Prod.snd := by + let replace : Prod Location NodeState -> Prod Location NodeState := + fun entry => + if entry.1 == target then (target, nextState) else entry + change + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) + (nodes.map replace)) = + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) nodes) + rw [List.find?_map] + have predicate : + ((fun entry : Prod Location NodeState => entry.1 == other) ∘ + replace) = + (fun entry => entry.1 == other) := by + funext entry + by_cases atTarget : entry.1 = target + · simp [replace, atTarget] + · simp [replace, atTarget] + rw [predicate] + cases found : + List.find? (fun entry : Prod Location NodeState => + entry.1 == other) nodes with + | none => simp + | some entry => + have condition : + (entry.1 == other) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == other) found + have entryOther : entry.1 = other := + beq_iff_eq.mp condition + have notTarget : entry.1 ≠ target := by + simpa [entryOther] using different + simp [replace, notTarget] + +theorem systemStep_node_keys_eq + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) : + after.nodes.map Prod.fst = before.nodes.map Prod.fst := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact replaceNode_keys target + (step config node event).state before.nodes + +theorem systemStep_preserves_node_locations + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (locations : + forall entry, entry ∈ before.nodes -> + entry.2.location = entry.1) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.location = entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, stateEq, _⟩ + rw [←stateEq] + apply replaceNode_locations + · exact locations + · calc + (step config node event).state.location = + node.location := step_preserves_location config node event + _ = key := + locations (key, node) (List.mem_of_find?_eq_some found) + _ = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + +theorem systemStep_other_node_eq + {config : Protocol.Config} + {before after : SystemState} + {target other : Location} + {event : Event} + {output : StepOutput} + (different : other ≠ target) + (transition : + systemStep config before target event = some (after, output)) : + (after.nodes.find? fun entry => entry.1 == other).map Prod.snd = + (before.nodes.find? fun entry => entry.1 == other).map Prod.snd := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact findNode_replaceNode_ne target other + (step config node event).state before.nodes different + +theorem next_active_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.active = before.active := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, _, rfl⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, _, _, rfl⟩ + simp + +theorem next_node_keys_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.system.nodes.map Prod.fst = + before.system.nodes.map Prod.fst := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, systemStep, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, systemStep, _, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + +theorem retry_system_eq + {config : Config} + {before after : State} + {source : Location} + (transition : next config before (.retry source) = some after) : + after.system = before.system := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + +theorem deliver_network_eq + {config : Config} + {before after : State} + {envelope : Envelope} + (transition : next config before (.deliver envelope) = some after) : + after.network = removeOne envelope before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + simp + +theorem timeout_network_eq + {config : Config} + {before after : State} + {target : Location} + (transition : next config before (.timeout target) = some after) : + after.network = before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + simp + +theorem deliver_other_node_eq + {config : Config} + {before after : State} + {envelope : Envelope} + {other : Location} + (different : other ≠ envelope.target) + (transition : next config before (.deliver envelope) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +theorem timeout_other_node_eq + {config : Config} + {before after : State} + {target other : Location} + (different : other ≠ target) + (transition : next config before (.timeout target) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +theorem next_sent_extends + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + exists added, after.sent = before.sent ++ added := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact ⟨retryMessages config source sourceState, rfl⟩ + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + +theorem next_openings_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall opening, opening ∈ before.openings -> + opening ∈ after.openings := by + intro opening membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + +theorem next_restarts_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall restart, restart ∈ before.restarts -> + restart ∈ after.restarts := by + intro restart membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + +theorem next_completed_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall completed, completed ∈ before.completed -> + completed ∈ after.completed := by + intro completed membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + +theorem retry_preserves_well_formed + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.retry source) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨sourceActive, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + constructor + · exact wellFormed.nodeKeys + · exact wellFormed.nodeKeysNodup + · exact wellFormed.nodeLocations + · exact wellFormed.activeNodup + · exact wellFormed.activeConfigured + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentValid envelope membership + · exact retryMessages_valid config source sourceState + sourceLocation envelope membership + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentSourceActive envelope membership + · rw [(retryMessages_source membership).1] + exact sourceActive + · intro envelope membership + rw [List.mem_append] at membership ⊢ + rcases membership with membership | membership + · exact Or.inl (wellFormed.networkSent envelope membership) + · exact Or.inr membership + · constructor + · exact wellFormed.historiesActive.openings + · exact wellFormed.historiesActive.restarts + · exact wellFormed.historiesActive.completed + +theorem deliver_preserves_well_formed + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (transition : next config before (.deliver envelope) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending + (mem_of_mem_removeOne envelope pending before.network membership) + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +theorem timeout_preserves_well_formed + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.timeout target) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨targetActive, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending membership + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +theorem next_preserves_well_formed + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (transition : next config before action = some after) : + WellFormed config after := by + cases action with + | retry source => + exact retry_preserves_well_formed wellFormed transition + | deliver envelope => + exact deliver_preserves_well_formed wellFormed transition + | timeout target => + exact timeout_preserves_well_formed wellFormed transition + +theorem reachable_well_formed + {config : Config} + {state : State} + (reachable : Reachable config state) : + WellFormed config state := by + induction reachable with + | initial active valid nodup configured => + exact initial_well_formed config active valid nodup configured + | step reachable transition wellFormed => + exact next_preserves_well_formed wellFormed transition + +theorem reachable_config_valid + {config : Config} + {state : State} + (reachable : Reachable config state) : + config.Valid := by + induction reachable with + | initial active valid nodup configured => exact valid + | step reachable transition valid => exact valid + +end DisasterRecovery.Protocol.Global From 5330b7da2e8f0f267be7662ade8788bbdf234e3c Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:07:15 +0100 Subject: [PATCH 04/12] Prove quorum and committed-prefix safety Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/DisasterRecovery.lean | 2 + .../DisasterRecovery/Protocol/Committed.lean | 258 +++ .../DisasterRecovery/Protocol/Quorum.lean | 1467 +++++++++++++++++ 3 files changed, 1727 insertions(+) create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean index c20571142be..e316316223a 100644 --- a/lean/disaster-recovery/DisasterRecovery.lean +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -2,3 +2,5 @@ import DisasterRecovery.Protocol.Model import DisasterRecovery.Protocol.Temporal import DisasterRecovery.Protocol.Global import DisasterRecovery.Protocol.Invariants +import DisasterRecovery.Protocol.Quorum +import DisasterRecovery.Protocol.Committed diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean new file mode 100644 index 00000000000..aeaec563bea --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean @@ -0,0 +1,258 @@ +import DisasterRecovery.Protocol.Quorum +import Mathlib.Tactic + +namespace DisasterRecovery.Protocol + +namespace TxID + +def PrefixOf (left right : TxID) : Prop := + left.view < right.view \/ + (left.view = right.view /\ left.seqno <= right.seqno) + +theorem prefix_refl (txid : TxID) : PrefixOf txid txid := by + simp [PrefixOf] + +theorem prefix_trans + {first second third : TxID} + (firstSecond : PrefixOf first second) + (secondThird : PrefixOf second third) : + PrefixOf first third := by + simp [PrefixOf] at firstSecond secondThird ⊢ + omega + +end TxID + +namespace Global + +theorem prefix_of_score_true + (leftName rightName : Location) + (left right : TxID) + (score : + txScoreGreater leftName left rightName right = true) : + TxID.PrefixOf right left := by + simp [txScoreGreater] at score + simp [TxID.PrefixOf] + omega + +theorem prefix_of_score_false + (leftName rightName : Location) + (left right : TxID) + (score : + txScoreGreater leftName left rightName right = false) : + TxID.PrefixOf left right := by + simp [txScoreGreater] at score + simp [TxID.PrefixOf] + omega + +theorem current_prefix_selectMaximum + (current candidate : Prod Location TxID) : + TxID.PrefixOf current.2 + (selectMaximum current candidate).2 := by + unfold selectMaximum + split + · rename_i score + exact prefix_of_score_true + candidate.1 current.1 candidate.2 current.2 score + · exact TxID.prefix_refl current.2 + +theorem candidate_prefix_selectMaximum + (current candidate : Prod Location TxID) : + TxID.PrefixOf candidate.2 + (selectMaximum current candidate).2 := by + unfold selectMaximum + split + · exact TxID.prefix_refl candidate.2 + · rename_i score + exact prefix_of_score_false + candidate.1 current.1 candidate.2 current.2 + (Bool.eq_false_iff.mpr score) + +theorem foldl_selectMaximum_upper_bound + (current member : Prod Location TxID) + (tail : List (Prod Location TxID)) + (membership : member = current \/ member ∈ tail) : + TxID.PrefixOf member.2 + (tail.foldl selectMaximum current).2 := by + induction tail generalizing current member with + | nil => + simp at membership + subst member + exact TxID.prefix_refl current.2 + | cons candidate rest ih => + simp only [List.foldl_cons] + rcases membership with currentMember | tailMember + · subst member + exact TxID.prefix_trans + (current_prefix_selectMaximum current candidate) + (ih (selectMaximum current candidate) + (selectMaximum current candidate) (Or.inl rfl)) + · rw [List.mem_cons] at tailMember + rcases tailMember with candidateMember | restMember + · subst member + exact TxID.prefix_trans + (candidate_prefix_selectMaximum current candidate) + (ih (selectMaximum current candidate) + (selectMaximum current candidate) (Or.inl rfl)) + · exact ih (selectMaximum current candidate) member + (Or.inr restMember) + +theorem maximumGossip_upper_bound + {gossips : List (Prod Location TxID)} + {selected member : Prod Location TxID} + (maximum : maximumGossip gossips = some selected) + (membership : member ∈ gossips) : + TxID.PrefixOf member.2 selected.2 := by + cases gossips with + | nil => simp at membership + | cons head tail => + simp [maximumGossip] at maximum + rw [←maximum] + apply foldl_selectMaximum_upper_bound head member tail + simpa using membership + +theorem foldl_selectMaximum_mem + (current : Prod Location TxID) + (tail : List (Prod Location TxID)) : + tail.foldl selectMaximum current ∈ current :: tail := by + induction tail generalizing current with + | nil => simp + | cons candidate rest ih => + simp only [List.foldl_cons] + have selected : + selectMaximum current candidate = current \/ + selectMaximum current candidate = candidate := by + unfold selectMaximum + split <;> simp + have member := + ih (selectMaximum current candidate) + rw [List.mem_cons] at member + rcases member with currentMember | restMember + · rw [currentMember] + rcases selected with selected | selected + · simp [selected] + · simp [selected] + · simp [restMember] + +theorem maximumGossip_mem + {gossips : List (Prod Location TxID)} + {selected : Prod Location TxID} + (maximum : maximumGossip gossips = some selected) : + selected ∈ gossips := by + cases gossips with + | nil => simp [maximumGossip] at maximum + | cons head tail => + simp [maximumGossip] at maximum + rw [←maximum] + exact foldl_selectMaximum_mem head tail + +theorem recoveredTxID_of_mem + {config : Config} + {location : Location} + {txid : TxID} + (valid : config.Valid) + (membership : (location, txid) ∈ config.recovered) : + recoveredTxID config location = some txid := by + have keysNodup : (config.recovered.map Prod.fst).Nodup := by + rw [valid.2.2] + exact valid.2.1 + unfold recoveredTxID + cases found : + config.recovered.find? fun entry => entry.1 == location with + | none => + rw [List.find?_eq_none] at found + exact False.elim + (found (location, txid) membership (by simp)) + | some entry => + have foundMember : entry ∈ config.recovered := + List.mem_of_find?_eq_some found + have foundLocation : entry.1 = location := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location TxID => + entry.1 == location) found) + have same : + entry = (location, txid) := + eq_of_key_eq keysNodup foundMember membership foundLocation + simp [same] + +def FullGossipSelection + (config : Config) + (state : State) + (opener : Location) : Prop := + exists vote, + vote ∈ state.sent /\ + vote.payload = .vote /\ + vote.target = opener /\ + forall gossip, + gossip ∈ vote.sourceState.gossips <-> + gossip ∈ config.recovered + +def DurableCommit (config : Config) (committed : TxID) : Prop := + exists location txid, + (location, txid) ∈ config.recovered /\ + TxID.PrefixOf committed txid + +theorem full_gossip_selection_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := by + have configValid := reachable_config_valid reachable + have wellFormed := reachable_well_formed reachable + have invariant := reachable_quorum_invariant reachable + rcases full with + ⟨vote, sent, payload, target, complete⟩ + have voteState := + retry_vote_state (wellFormed.sentValid vote sent) payload + rcases invariant.sentVotesSelected vote sent payload with + ⟨selectedTarget, selectedTxID, choice, selected⟩ + have selectedTargetEq : selectedTarget = vote.target := + Option.some.inj (choice.symm.trans voteState.2) + rw [selectedTargetEq, target] at selected + rcases durable with + ⟨durableLocation, durableTxID, durableMember, committedDurable⟩ + have durableGossip : + (durableLocation, durableTxID) ∈ vote.sourceState.gossips := + (complete (durableLocation, durableTxID)).2 durableMember + have durableMaximum := + maximumGossip_upper_bound selected durableGossip + have selectedGossip : + (opener, selectedTxID) ∈ vote.sourceState.gossips := + maximumGossip_mem selected + have selectedRecovered : + (opener, selectedTxID) ∈ config.recovered := + (complete (opener, selectedTxID)).1 selectedGossip + exact + ⟨selectedTxID, + recoveredTxID_of_mem configValid selectedRecovered, + TxID.prefix_trans committedDurable durableMaximum⟩ + +/-- +Quorum opening scopes the result to an actual decision, while the separate +`FullGossipSelection` premise carries the completeness requirement. Quorum +opening alone does not imply complete gossip because voting may follow a +gossip timeout. +-/ +theorem quorum_open_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (_opened : QuorumOpened state opener) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := + full_gossip_selection_preserves_commit reachable full durable + +end Global + +end DisasterRecovery.Protocol diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean new file mode 100644 index 00000000000..7413f3f435e --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean @@ -0,0 +1,1467 @@ +import DisasterRecovery.Protocol.Invariants +import Mathlib.Tactic + +namespace DisasterRecovery.Protocol.Global + +def SentVote (state : State) (voter target : Location) : Prop := + exists envelope, + envelope ∈ state.sent /\ + envelope.source = voter /\ + envelope.target = target /\ + envelope.payload = .vote + +def NodeVotesNodup (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + entry.2.votes.Nodup + +def NodeVotesSent (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + forall voter, voter ∈ entry.2.votes -> + SentVote state voter entry.1 + +def SentVotesFunctional (state : State) : Prop := + forall voter first second, + SentVote state voter first -> + SentVote state voter second -> + first = second + +def SentVoteStable (state : State) : Prop := + forall envelope, envelope ∈ state.sent -> + envelope.payload = .vote -> + forall entry, entry ∈ state.system.nodes -> + entry.1 = envelope.source -> + entry.2.phase ≠ .gossiping /\ + (entry.2.phase = .voting -> + entry.2.chosen = some envelope.target) + +def NodeVotingSelection (state : NodeState) : Prop := + exists target txid, + state.chosen = some target /\ + maximumGossip state.gossips = some (target, txid) + +def VotingSelectionsValid (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + entry.2.phase = .voting -> + NodeVotingSelection entry.2 + +def SentVotesSelected (state : State) : Prop := + forall envelope, envelope ∈ state.sent -> + envelope.payload = .vote -> + NodeVotingSelection envelope.sourceState + +structure Opening.Valid + (config : Config) + (globalState : State) + (opening : Opening) : Prop where + location : opening.state.location = opening.node + phase : opening.state.phase = .opening + kind : opening.state.openKind = some opening.kind + votesNodup : opening.state.votes.Nodup + quorum : + opening.kind = .quorum -> + voteQuorum config.protocol <= opening.state.votes.length + votesSent : + forall voter, voter ∈ opening.state.votes -> + SentVote globalState voter opening.node + +def OpeningsValid (config : Config) (state : State) : Prop := + forall opening, opening ∈ state.openings -> + opening.Valid config state + +structure QuorumInvariant (config : Config) (state : State) : Prop where + votesNodup : NodeVotesNodup state + votesSent : NodeVotesSent state + sentVoteStable : SentVoteStable state + sentVotesFunctional : SentVotesFunctional state + votingSelections : VotingSelectionsValid state + sentVotesSelected : SentVotesSelected state + openingsValid : OpeningsValid config state + +theorem insertVote_nodup + (source : Location) + {votes : List Location} + (nodup : votes.Nodup) : + (insertVote source votes).Nodup := by + unfold insertVote + split + · exact nodup + · rename_i absent + apply (List.mergeSort_perm _ _).symm.nodup + rw [List.nodup_cons] + exact + ⟨fun member => absent (List.contains_iff_mem.mpr member), nodup⟩ + +theorem mem_insertVote + {member source : Location} + {votes : List Location} + (membership : member ∈ insertVote source votes) : + member ∈ votes \/ member = source := by + unfold insertVote at membership + split at membership + · exact Or.inl membership + · have unsorted := + (List.mergeSort_perm _ _).mem_iff.mp membership + rw [List.mem_cons] at unsorted + exact unsorted.symm + +theorem step_preserves_votes_nodup + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (nodup : state.votes.Nodup) : + (step config state event).state.votes.Nodup := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals + repeat first | split | simp_all [insertVote_nodup] + +def acceptedVoteSource : Event -> Option Location + | .receiveVote source .accepted => some source + | _ => none + +theorem step_votes_shape + (config : Protocol.Config) + (state : NodeState) + (event : Event) : + (step config state event).state.votes = state.votes \/ + exists source, + acceptedVoteSource event = some source /\ + (step config state event).state.votes = + insertVote source state.votes := by + cases event + all_goals try cases_type Validation + all_goals + simp [acceptedVoteSource, step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +theorem step_vote_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (voter : Location) + (membership : voter ∈ (step config state event).state.votes) : + voter ∈ state.votes \/ + acceptedVoteSource event = some voter := by + rcases step_votes_shape config state event with + unchanged | ⟨source, sourceEq, changed⟩ + · rw [unchanged] at membership + exact Or.inl membership + · rw [changed] at membership + rcases mem_insertVote membership with old | added + · exact Or.inl old + · subst source + exact Or.inr sourceEq + +theorem step_preserves_non_gossiping + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (pastGossip : state.phase ≠ .gossiping) : + (step config state event).state.phase ≠ .gossiping := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +theorem voting_step_preserves_choice + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (pastGossip : state.phase ≠ .gossiping) + (stillVoting : (step config state event).state.phase = .voting) : + state.phase = .voting /\ + (step config state event).state.chosen = state.chosen := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] at stillVoting ⊢ + all_goals repeat first | split at stillVoting | split | simp_all + +theorem step_preserves_voting_selection + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (before : + state.phase = .voting -> + NodeVotingSelection state) + (voting : (step config state event).state.phase = .voting) : + NodeVotingSelection (step config state event).state := by + cases event + all_goals try cases_type Validation + all_goals + simp [NodeVotingSelection, step, rejected, advance, + advanceTimeoutLane, validTimeout] at before voting ⊢ + all_goals + repeat first | split at voting | split | simp_all | aesop + +theorem retry_vote_state + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) + (vote : envelope.payload = .vote) : + envelope.sourceState.phase = .voting /\ + envelope.sourceState.chosen = some envelope.target := by + rcases valid_envelope_effect valid with + ⟨effect, member, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => + simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] at vote + contradiction + | sendVote target => + simp [messageForEffect] at created + rw [←created] at vote ⊢ + cases phase : envelope.sourceState.phase <;> + simp [step, phase] at member + next => + cases chosen : envelope.sourceState.chosen <;> + simp_all + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at vote + contradiction + | opening kind => + simp [messageForEffect] at created + | restart chosen => + simp [messageForEffect] at created + | completed => + simp [messageForEffect] at created + | rejected reason => + simp [messageForEffect] at created + +theorem opening_effect_state + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (kind : OpenKind) + (opening : .opening kind ∈ (step config state event).effects) : + (step config state event).state.phase = .opening /\ + (step config state event).state.openKind = some kind := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opening ⊢ + all_goals + repeat first | split at opening | split | simp_all | aesop + +theorem quorum_effect_has_threshold + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (opening : + .opening .quorum ∈ (step config state event).effects) : + voteQuorum config <= + (step config state event).state.votes.length := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opening ⊢ + all_goals + repeat first | split at opening | split | simp_all | aesop + +theorem sentVote_mono + {before after : State} + {voter target : Location} + (sent : forall envelope, envelope ∈ before.sent -> + envelope ∈ after.sent) + (vote : SentVote before voter target) : + SentVote after voter target := by + rcases vote with + ⟨envelope, membership, source, destination, payload⟩ + exact + ⟨envelope, sent envelope membership, source, destination, payload⟩ + +theorem opening_valid_of_sent_eq + {config : Config} + {before after : State} + {opening : Opening} + (sentEq : after.sent = before.sent) + (valid : opening.Valid config before) : + opening.Valid config after := by + rcases valid with + ⟨location, phase, kind, nodup, quorum, votesSent⟩ + constructor + · exact location + · exact phase + · exact kind + · exact nodup + · exact quorum + · intro voter membership + apply sentVote_mono + · intro envelope sent + rw [sentEq] + exact sent + · exact votesSent voter membership + +theorem opening_valid_mono + {config : Config} + {before after : State} + {opening : Opening} + (sent : + forall envelope, envelope ∈ before.sent -> + envelope ∈ after.sent) + (valid : opening.Valid config before) : + opening.Valid config after := by + rcases valid with + ⟨location, phase, kind, nodup, quorum, votesSent⟩ + constructor + · exact location + · exact phase + · exact kind + · exact nodup + · exact quorum + · intro voter membership + exact sentVote_mono sent (votesSent voter membership) + +theorem recordEffect_preserves_openings_valid + {config : Config} + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + (valid : OpeningsValid config state) + (newValid : + forall kind, + effect = .opening kind -> + Opening.Valid config state + { node, kind, state := nodeState }) : + OpeningsValid config + (recordEffect node nodeState state effect) := by + intro opening membership + cases effect with + | opening kind => + simp [recordEffect] at membership + rcases membership with rfl | old + · apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.opening kind)) + rfl + exact newValid kind rfl + · apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.opening kind)) + rfl + exact valid opening old + | sendGossip target => + exact valid opening membership + | sendVote target => + exact valid opening membership + | sendIAmOpen target => + exact valid opening membership + | restart target => + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.restart target)) + rfl + exact valid opening membership + | completed => + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state .completed) + rfl + exact valid opening membership + | rejected reason => + exact valid opening membership + +theorem recordEffects_preserves_openings_valid + {config : Config} + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + (valid : OpeningsValid config state) + (newValid : + forall kind, + .opening kind ∈ effects -> + Opening.Valid config state + { node, kind, state := nodeState }) : + OpeningsValid config + (recordEffects node nodeState effects state) := by + induction effects generalizing state with + | nil => exact valid + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + apply ih + · apply recordEffect_preserves_openings_valid valid + intro kind effectEq + subst effect + exact newValid kind (by simp) + · intro kind membership + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state effect) + (by cases effect <;> rfl) + exact newValid kind (by simp [membership]) + +theorem eventFor_vote_source + {envelope : Envelope} + {voter : Location} + (source : + acceptedVoteSource (eventFor envelope) = some voter) : + envelope.payload = .vote /\ + envelope.source = voter := by + cases payload : envelope.payload <;> + simp_all [eventFor, acceptedVoteSource] + +theorem systemStep_preserves_votes_nodup + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (nodup : + forall entry, entry ∈ before.nodes -> + entry.2.votes.Nodup) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.votes.Nodup := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, stateEq, _⟩ + rw [←stateEq] + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · apply step_preserves_votes_nodup + exact nodup (key, node) (List.mem_of_find?_eq_some found) + · exact nodup previous previousMember + +theorem systemStep_preserves_voting_selections + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (valid : + forall entry, entry ∈ before.nodes -> + entry.2.phase = .voting -> + NodeVotingSelection entry.2) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .voting -> + NodeVotingSelection entry.2 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership voting + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + apply step_preserves_voting_selection config node event + · exact valid (key, node) + (List.mem_of_find?_eq_some found) + · simpa [atTarget, outputEq] using voting + · rename_i notTarget + exact valid previous previousMember + (by simpa [notTarget] using voting) + +theorem systemStep_output_location + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (locations : + forall entry, entry ∈ before.nodes -> + entry.2.location = entry.1) + (transition : + systemStep config before target event = some (after, output)) : + output.state.location = target := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, _, outputEq⟩ + calc + output.state.location = + node.location := by + rw [←outputEq] + exact step_preserves_location config node event + _ = key := + locations (key, node) (List.mem_of_find?_eq_some found) + _ = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + +theorem systemStep_output_mem + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) : + (target, output.state) ∈ after.nodes := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq, replaceNode, List.mem_map] + refine ⟨(key, node), List.mem_of_find?_eq_some found, ?_⟩ + have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + simp [keyEq, outputEq] + +theorem systemStep_opening_effect_state + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {kind : OpenKind} + (transition : + systemStep config before target event = some (after, output)) + (opening : .opening kind ∈ output.effects) : + output.state.phase = .opening /\ + output.state.openKind = some kind := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, _, _, outputEq⟩ + rw [←outputEq] at opening ⊢ + exact opening_effect_state config node event kind opening + +theorem systemStep_quorum_effect_has_threshold + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) + (opening : .opening .quorum ∈ output.effects) : + voteQuorum config <= output.state.votes.length := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, _, _, outputEq⟩ + rw [←outputEq] at opening ⊢ + exact quorum_effect_has_threshold config node event opening + +theorem initial_node_votes_nodup + (config : Config) + (active : List Location) : + NodeVotesNodup (initial config active) := by + simp [NodeVotesNodup, Global.initial, initialSystem, initialNode] + +theorem initial_node_votes_sent + (config : Config) + (active : List Location) : + NodeVotesSent (initial config active) := by + simp [NodeVotesSent, Global.initial, initialSystem, initialNode] + +theorem initial_sent_votes_functional + (config : Config) + (active : List Location) : + SentVotesFunctional (initial config active) := by + simp [SentVotesFunctional, SentVote, Global.initial] + +theorem initial_sent_vote_stable + (config : Config) + (active : List Location) : + SentVoteStable (initial config active) := by + simp [SentVoteStable, Global.initial] + +theorem initial_voting_selections + (config : Config) + (active : List Location) : + VotingSelectionsValid (initial config active) := by + simp [VotingSelectionsValid, Global.initial, initialSystem, initialNode] + +theorem initial_sent_votes_selected + (config : Config) + (active : List Location) : + SentVotesSelected (initial config active) := by + simp [SentVotesSelected, Global.initial] + +theorem initial_openings_valid + (config : Config) + (active : List Location) : + OpeningsValid config (initial config active) := by + simp [OpeningsValid, Global.initial] + +theorem systemStep_preserves_node_votes_sent + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (votesSent : NodeVotesSent beforeState) + (carry : + forall voter destination, + SentVote beforeState voter destination -> + SentVote afterState voter destination) + (introduced : + forall voter, + acceptedVoteSource event = some voter -> + SentVote afterState voter target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + forall voter, voter ∈ entry.2.votes -> + SentVote afterState voter entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership voter vote + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + have targetEq : previous.1 = target := + beq_iff_eq.mp atTarget + rcases step_vote_origin config node event voter + (by simpa [outputEq, atTarget] using vote) with + old | added + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + apply carry + rw [←keyEq] + exact votesSent (key, node) + (by + rw [beforeSystem] + exact List.mem_of_find?_eq_some found) + voter old + · exact introduced voter added + · rename_i notTarget + apply carry + exact votesSent previous + (by + rw [beforeSystem] + exact previousMember) + voter (by simpa [notTarget] using vote) + +theorem eq_of_key_eq + {α : Type} + {nodes : List (Prod Location α)} + (nodup : (nodes.map Prod.fst).Nodup) + {first second : Prod Location α} + (firstMember : first ∈ nodes) + (secondMember : second ∈ nodes) + (keyEq : first.1 = second.1) : + first = second := by + induction nodes generalizing first second with + | nil => simp at firstMember + | cons head tail ih => + rw [List.map_cons, List.nodup_cons] at nodup + rcases nodup with ⟨headFresh, tailNodup⟩ + rw [List.mem_cons] at firstMember secondMember + rcases firstMember with rfl | firstTail + · rcases secondMember with rfl | secondTail + · rfl + · exfalso + apply headFresh + rw [List.mem_map] + exact ⟨second, secondTail, keyEq.symm⟩ + · rcases secondMember with rfl | secondTail + · exfalso + apply headFresh + rw [List.mem_map] + exact ⟨first, firstTail, keyEq⟩ + · exact ih tailNodup firstTail secondTail keyEq + +theorem systemStep_preserves_vote_stability + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {envelope : Envelope} + (stable : + forall entry, entry ∈ before.nodes -> + entry.1 = envelope.source -> + entry.2.phase ≠ .gossiping /\ + (entry.2.phase = .voting -> + entry.2.chosen = some envelope.target)) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.1 = envelope.source -> + entry.2.phase ≠ .gossiping /\ + (entry.2.phase = .voting -> + entry.2.chosen = some envelope.target) := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership sourceEq + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + have targetEq : previous.1 = target := + beq_iff_eq.mp atTarget + have targetSource : target = envelope.source := by + simpa [atTarget] using sourceEq + have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + have beforeStable := + stable (key, node) (List.mem_of_find?_eq_some found) + (keyEq.trans targetSource) + constructor + · exact step_preserves_non_gossiping config node event + beforeStable.1 + · intro voting + rcases voting_step_preserves_choice config node event + beforeStable.1 voting with ⟨beforeVoting, chosenEq⟩ + rw [chosenEq] + exact beforeStable.2 beforeVoting + · rename_i notTarget + exact stable previous previousMember + (by simpa [notTarget] using sourceEq) + +theorem next_preserves_node_votes_nodup + {config : Config} + {before after : State} + {action : Action} + (nodup : NodeVotesNodup before) + (transition : next config before action = some after) : + NodeVotesNodup after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact nodup + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_votes_nodup nodup systemStep + entry membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_votes_nodup nodup systemStep + entry membership + +theorem next_preserves_voting_selections + {config : Config} + {before after : State} + {action : Action} + (valid : VotingSelectionsValid before) + (transition : next config before action = some after) : + VotingSelectionsValid after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership voting + rw [recordEffects_system] at membership + exact systemStep_preserves_voting_selections valid systemStep + entry membership voting + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership voting + rw [recordEffects_system] at membership + exact systemStep_preserves_voting_selections valid systemStep + entry membership voting + +theorem retry_preserves_sent_votes_selected + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (votingSelections : VotingSelectionsValid before) + (selected : SentVotesSelected before) + (transition : next config before (.retry source) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · exact selected envelope old payload + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + have identity := retryMessages_source added + rw [identity.2] at voteState + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have sourceSelection := + votingSelections entry (List.mem_of_find?_eq_some findEq) + (by simpa [stateEq] using voteState.1) + simpa [identity.2, stateEq] using sourceSelection + +theorem deliver_preserves_sent_votes_selected + {config : Config} + {before after : State} + {envelope : Envelope} + (selected : SentVotesSelected before) + (transition : next config before (.deliver envelope) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, stateEq⟩ + rw [←stateEq] + intro vote membership payload + rw [recordEffects_sent] at membership + exact selected vote membership payload + +theorem timeout_preserves_sent_votes_selected + {config : Config} + {before after : State} + {target : Location} + (selected : SentVotesSelected before) + (transition : next config before (.timeout target) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, stateEq⟩ + rw [←stateEq] + intro vote membership payload + rw [recordEffects_sent] at membership + exact selected vote membership payload + +theorem retry_preserves_node_votes_sent + {config : Config} + {before after : State} + {source : Location} + (votesSent : NodeVotesSent before) + (transition : next config before (.retry source) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + intro entry membership voter vote + apply sentVote_mono (before := before) + · intro envelope sent + exact List.mem_append_left _ sent + · exact votesSent entry membership voter vote + +theorem deliver_preserves_node_votes_sent + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (votesSent : NodeVotesSent before) + (transition : next config before (.deliver envelope) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨inNetwork, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership voter vote + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall oldVoter oldTarget, + SentVote before oldVoter oldTarget -> + SentVote afterState oldVoter oldTarget := by + intro oldVoter oldTarget oldVote + apply sentVote_mono (before := before) (after := afterState) + · intro sent sentMember + simpa [afterState] using sentMember + · exact oldVote + have introducedVote : + forall newVoter, + acceptedVoteSource (eventFor envelope) = some newVoter -> + SentVote afterState newVoter envelope.target := by + intro newVoter introduced + rcases eventFor_vote_source introduced with + ⟨payload, source⟩ + subst newVoter + refine ⟨envelope, ?_, rfl, rfl, payload⟩ + simp [afterState] + exact wellFormed.networkSent envelope + inNetwork + exact systemStep_preserves_node_votes_sent + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl votesSent carry introducedVote systemStep + entry membership voter vote + +theorem timeout_preserves_node_votes_sent + {config : Config} + {before after : State} + {target : Location} + (votesSent : NodeVotesSent before) + (transition : next config before (.timeout target) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership voter vote + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall oldVoter oldTarget, + SentVote before oldVoter oldTarget -> + SentVote afterState oldVoter oldTarget := by + intro oldVoter oldTarget oldVote + apply sentVote_mono (before := before) (after := afterState) + · intro sent sentMember + simpa [afterState] using sentMember + · exact oldVote + have introducedVote : + forall newVoter, + acceptedVoteSource Event.timeout = some newVoter -> + SentVote afterState newVoter target := by + intro newVoter introduced + simp [acceptedVoteSource] at introduced + exact systemStep_preserves_node_votes_sent + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl votesSent carry introducedVote systemStep + entry membership voter vote + +theorem retry_preserves_openings_valid + {config : Config} + {before after : State} + {source : Location} + (valid : OpeningsValid config before) + (transition : next config before (.retry source) = some after) : + OpeningsValid config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro opening membership + apply opening_valid_mono + · intro envelope sent + exact List.mem_append_left _ sent + · exact valid opening membership + +theorem deliver_preserves_openings_valid + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (votesNodup : NodeVotesNodup before) + (votesSent : NodeVotesSent before) + (valid : OpeningsValid config before) + (transition : next config before (.deliver envelope) = some after) : + OpeningsValid config after := by + have afterNodup := + next_preserves_node_votes_nodup votesNodup transition + have afterVotesSent := + deliver_preserves_node_votes_sent wellFormed votesSent transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] at afterNodup afterVotesSent ⊢ + let delivered : State := { + before with + system + network := removeOne envelope before.network + } + apply recordEffects_preserves_openings_valid + · intro opening membership + apply opening_valid_of_sent_eq + (before := before) (after := delivered) rfl + exact valid opening membership + · intro kind openingEffect + have effectState := + systemStep_opening_effect_state systemStep openingEffect + constructor + · exact systemStep_output_location + wellFormed.nodeLocations systemStep + · exact effectState.1 + · exact effectState.2 + · apply afterNodup (envelope.target, output.state) + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · intro quorumKind + have kindEq : kind = .quorum := by simpa using quorumKind + rw [kindEq] at openingEffect + simpa using + systemStep_quorum_effect_has_threshold systemStep openingEffect + · intro voter vote + have sent := + afterVotesSent (envelope.target, output.state) + (by + rw [recordEffects_system] + exact systemStep_output_mem systemStep) + voter vote + simpa [SentVote, delivered] using sent + +theorem timeout_preserves_openings_valid + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (votesNodup : NodeVotesNodup before) + (votesSent : NodeVotesSent before) + (valid : OpeningsValid config before) + (transition : next config before (.timeout target) = some after) : + OpeningsValid config after := by + have afterNodup := + next_preserves_node_votes_nodup votesNodup transition + have afterVotesSent := + timeout_preserves_node_votes_sent votesSent transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] at afterNodup afterVotesSent ⊢ + let timedOut : State := { before with system } + apply recordEffects_preserves_openings_valid + · intro opening membership + apply opening_valid_of_sent_eq + (before := before) (after := timedOut) rfl + exact valid opening membership + · intro kind openingEffect + have effectState := + systemStep_opening_effect_state systemStep openingEffect + constructor + · exact systemStep_output_location + wellFormed.nodeLocations systemStep + · exact effectState.1 + · exact effectState.2 + · apply afterNodup (target, output.state) + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · intro quorumKind + have kindEq : kind = .quorum := by simpa using quorumKind + rw [kindEq] at openingEffect + simpa using + systemStep_quorum_effect_has_threshold systemStep openingEffect + · intro voter vote + have sent := + afterVotesSent (target, output.state) + (by + rw [recordEffects_system] + exact systemStep_output_mem systemStep) + voter vote + simpa [SentVote, timedOut] using sent + +theorem retry_preserves_sent_vote_stable + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (stable : SentVoteStable before) + (transition : next config before (.retry source) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [List.mem_append] at membership + rcases membership with old | added + · exact stable envelope old payload entry entryMember keyEq + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + rcases retryMessages_source added with + ⟨sourceEq, stateEq⟩ + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨foundEntry, findEq, foundStateEq⟩ + have foundMember : foundEntry ∈ before.system.nodes := + List.mem_of_find?_eq_some findEq + have foundKey : foundEntry.1 = source := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == source) findEq) + have sameEntry : entry = foundEntry := + eq_of_key_eq wellFormed.nodeKeysNodup entryMember foundMember + ((keyEq.trans sourceEq).trans foundKey.symm) + subst entry + rw [foundStateEq, ←stateEq] + exact ⟨by simp [voteState.1], fun _ => voteState.2⟩ + +theorem deliver_preserves_sent_vote_stable + {config : Config} + {before after : State} + {delivered : Envelope} + (stable : SentVoteStable before) + (transition : next config before (.deliver delivered) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [recordEffects_sent] at membership + rw [recordEffects_system] at entryMember + exact systemStep_preserves_vote_stability + (fun previous previousMember source => + stable envelope membership payload previous previousMember source) + systemStep entry entryMember keyEq + +theorem timeout_preserves_sent_vote_stable + {config : Config} + {before after : State} + {target : Location} + (stable : SentVoteStable before) + (transition : next config before (.timeout target) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [recordEffects_sent] at membership + rw [recordEffects_system] at entryMember + exact systemStep_preserves_vote_stability + (fun previous previousMember source => + stable envelope membership payload previous previousMember source) + systemStep entry entryMember keyEq + +theorem sentVote_stable_at_node + {state : State} + {voter target : Location} + {current : NodeState} + (stable : SentVoteStable state) + (vote : SentVote state voter target) + (found : nodeState state voter = some current) : + current.phase ≠ .gossiping /\ + (current.phase = .voting -> + current.chosen = some target) := by + rcases vote with + ⟨envelope, sent, sourceEq, targetEq, payload⟩ + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have entryMember : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some findEq + have entryKey : entry.1 = voter := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == voter) findEq) + have result := + stable envelope sent payload entry entryMember + (entryKey.trans sourceEq.symm) + rw [stateEq] at result + simpa [targetEq] using result + +theorem retry_preserves_sent_votes_functional + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (functional : SentVotesFunctional before) + (stable : SentVoteStable before) + (transition : next config before (.retry source) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + have classify : + forall voter target, + SentVote + { + before with + network := before.network ++ + retryMessages config source sourceState + sent := before.sent ++ + retryMessages config source sourceState + } + voter target -> + SentVote before voter target \/ + (voter = source /\ + sourceState.phase = .voting /\ + sourceState.chosen = some target) := by + intro voter target vote + rcases vote with + ⟨envelope, membership, sourceEq, targetEq, payload⟩ + rw [List.mem_append] at membership + rcases membership with old | added + · exact Or.inl + ⟨envelope, old, sourceEq, targetEq, payload⟩ + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + have retryIdentity := retryMessages_source added + rw [retryIdentity.2] at voteState + exact Or.inr + ⟨sourceEq.symm.trans retryIdentity.1, + voteState.1, + by simpa [targetEq] using voteState.2⟩ + intro voter first second firstVote secondVote + rcases classify voter first firstVote with + firstOld | ⟨firstSource, firstPhase, firstChoice⟩ + · rcases classify voter second secondVote with + secondOld | ⟨secondSource, secondPhase, secondChoice⟩ + · exact functional voter first second firstOld secondOld + · have oldState := + sentVote_stable_at_node stable firstOld + (by simpa [secondSource] using found) + have oldChoice := oldState.2 secondPhase + rw [oldChoice] at secondChoice + exact Option.some.inj secondChoice + · rcases classify voter second secondVote with + secondOld | ⟨secondSource, secondPhase, secondChoice⟩ + · have oldState := + sentVote_stable_at_node stable secondOld + (by simpa [firstSource] using found) + have oldChoice := oldState.2 firstPhase + rw [oldChoice] at firstChoice + exact (Option.some.inj firstChoice).symm + · rw [firstChoice] at secondChoice + exact Option.some.inj secondChoice + +theorem deliver_preserves_sent_votes_functional + {config : Config} + {before after : State} + {envelope : Envelope} + (functional : SentVotesFunctional before) + (transition : next config before (.deliver envelope) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, stateEq⟩ + rw [←stateEq] + intro voter first second firstVote secondVote + apply functional voter first second + · simpa [SentVote] using firstVote + · simpa [SentVote] using secondVote + +theorem timeout_preserves_sent_votes_functional + {config : Config} + {before after : State} + {target : Location} + (functional : SentVotesFunctional before) + (transition : next config before (.timeout target) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, stateEq⟩ + rw [←stateEq] + intro voter first second firstVote secondVote + apply functional voter first second + · simpa [SentVote] using firstVote + · simpa [SentVote] using secondVote + +theorem initial_quorum_invariant + (config : Config) + (active : List Location) : + QuorumInvariant config (initial config active) := { + votesNodup := initial_node_votes_nodup config active + votesSent := initial_node_votes_sent config active + sentVoteStable := initial_sent_vote_stable config active + sentVotesFunctional := initial_sent_votes_functional config active + votingSelections := initial_voting_selections config active + sentVotesSelected := initial_sent_votes_selected config active + openingsValid := initial_openings_valid config active +} + +theorem next_preserves_quorum_invariant + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (invariant : QuorumInvariant config before) + (transition : next config before action = some after) : + QuorumInvariant config after := by + cases action with + | retry source => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact retry_preserves_node_votes_sent + invariant.votesSent transition + · exact retry_preserves_sent_vote_stable + wellFormed invariant.sentVoteStable transition + · exact retry_preserves_sent_votes_functional + wellFormed invariant.sentVotesFunctional + invariant.sentVoteStable transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact retry_preserves_sent_votes_selected + wellFormed invariant.votingSelections + invariant.sentVotesSelected transition + · exact retry_preserves_openings_valid + invariant.openingsValid transition + | deliver envelope => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact deliver_preserves_node_votes_sent + wellFormed invariant.votesSent transition + · exact deliver_preserves_sent_vote_stable + invariant.sentVoteStable transition + · exact deliver_preserves_sent_votes_functional + invariant.sentVotesFunctional transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact deliver_preserves_sent_votes_selected + invariant.sentVotesSelected transition + · exact deliver_preserves_openings_valid + wellFormed invariant.votesNodup invariant.votesSent + invariant.openingsValid transition + | timeout target => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact timeout_preserves_node_votes_sent + invariant.votesSent transition + · exact timeout_preserves_sent_vote_stable + invariant.sentVoteStable transition + · exact timeout_preserves_sent_votes_functional + invariant.sentVotesFunctional transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact timeout_preserves_sent_votes_selected + invariant.sentVotesSelected transition + · exact timeout_preserves_openings_valid + wellFormed invariant.votesNodup invariant.votesSent + invariant.openingsValid transition + +theorem reachable_quorum_invariant + {config : Config} + {state : State} + (reachable : Reachable config state) : + QuorumInvariant config state := by + induction reachable with + | initial active valid nodup configured => + exact initial_quorum_invariant config active + | step reachable transition invariant => + exact next_preserves_quorum_invariant + (reachable_well_formed reachable) invariant transition + +theorem quorum_lists_intersect + {α : Type} + [DecidableEq α] + (expected first second : List α) + (firstNodup : first.Nodup) + (secondNodup : second.Nodup) + (firstSubset : + forall value, value ∈ first -> value ∈ expected) + (secondSubset : + forall value, value ∈ second -> value ∈ expected) + (firstQuorum : + expected.length / 2 + 1 <= first.length) + (secondQuorum : + expected.length / 2 + 1 <= second.length) : + exists value, value ∈ first /\ value ∈ second := by + by_contra noShared + push_neg at noShared + have disjoint : Disjoint first.toFinset second.toFinset := + Finset.disjoint_left.mpr (by + intro value firstMember secondMember + exact noShared value + (List.mem_toFinset.mp firstMember) + (List.mem_toFinset.mp secondMember)) + have unionSubset : + first.toFinset ∪ second.toFinset ⊆ expected.toFinset := by + intro value membership + rw [Finset.mem_union] at membership + rw [List.mem_toFinset] + exact membership.elim + (fun member => + firstSubset value (List.mem_toFinset.mp member)) + (fun member => + secondSubset value (List.mem_toFinset.mp member)) + have unionCard := Finset.card_le_card unionSubset + rw [Finset.card_union_of_disjoint disjoint, + List.toFinset_card_of_nodup firstNodup, + List.toFinset_card_of_nodup secondNodup] at unionCard + have expectedCard := List.toFinset_card_le expected + omega + +def QuorumOpened (state : State) (node : Location) : Prop := + exists opening, + opening ∈ state.openings /\ + opening.node = node /\ + opening.kind = .quorum + +theorem opening_vote_configured + {config : Config} + {state : State} + {opening : Opening} + (wellFormed : WellFormed config state) + (valid : opening.Valid config state) + {voter : Location} + (vote : voter ∈ opening.state.votes) : + voter ∈ config.protocol.expectedLocations := by + rcases valid.votesSent voter vote with + ⟨envelope, sent, sourceEq, _, _⟩ + apply wellFormed.activeConfigured voter + simpa [sourceEq] using + wellFormed.sentSourceActive envelope sent + +theorem quorum_opener_unique + {config : Config} + {state : State} + {first second : Location} + (reachable : Reachable config state) + (firstOpened : QuorumOpened state first) + (secondOpened : QuorumOpened state second) : + first = second := by + have wellFormed := reachable_well_formed reachable + have invariant := reachable_quorum_invariant reachable + rcases firstOpened with + ⟨firstOpening, firstMember, firstNode, firstKind⟩ + rcases secondOpened with + ⟨secondOpening, secondMember, secondNode, secondKind⟩ + have firstValid := + invariant.openingsValid firstOpening firstMember + have secondValid := + invariant.openingsValid secondOpening secondMember + rcases quorum_lists_intersect + config.protocol.expectedLocations + firstOpening.state.votes + secondOpening.state.votes + firstValid.votesNodup + secondValid.votesNodup + (fun voter vote => + opening_vote_configured wellFormed firstValid vote) + (fun voter vote => + opening_vote_configured wellFormed secondValid vote) + (by + simpa [voteQuorum] using firstValid.quorum firstKind) + (by + simpa [voteQuorum] using secondValid.quorum secondKind) with + ⟨voter, firstVote, secondVote⟩ + have targetEq := + invariant.sentVotesFunctional voter + firstOpening.node secondOpening.node + (firstValid.votesSent voter firstVote) + (secondValid.votesSent voter secondVote) + exact firstNode.symm.trans (targetEq.trans secondNode) + +end DisasterRecovery.Protocol.Global From e9731105e6770f60c136edb2d134168a087290be Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:07:24 +0100 Subject: [PATCH 05/12] Prove fair global recovery progress Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/DisasterRecovery.lean | 1 + .../Protocol/GlobalTemporal.lean | 3168 +++++++++++++++++ 2 files changed, 3169 insertions(+) create mode 100644 lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean index e316316223a..009747c7166 100644 --- a/lean/disaster-recovery/DisasterRecovery.lean +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -4,3 +4,4 @@ import DisasterRecovery.Protocol.Global import DisasterRecovery.Protocol.Invariants import DisasterRecovery.Protocol.Quorum import DisasterRecovery.Protocol.Committed +import DisasterRecovery.Protocol.GlobalTemporal diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean new file mode 100644 index 00000000000..c7cac044b5f --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean @@ -0,0 +1,3168 @@ +import DisasterRecovery.Protocol.Committed +import DisasterRecovery.Protocol.Temporal +import Mathlib.Tactic + +namespace DisasterRecovery.Protocol.Global + +structure Execution (config : Config) where + states : Nat -> State + actions : Nat -> Action + step_succ : forall n, + next config (states n) (actions n) = some (states (n + 1)) + +def HasPhase (state : State) (node : Location) (phase : Phase) : Prop := + exists nodeState, + Global.nodeState state node = some nodeState /\ + nodeState.phase = phase + +def HasGossip (state : State) (node : Location) : Prop := + exists nodeState, + Global.nodeState state node = some nodeState /\ + nodeState.gossips ≠ [] + +def HasVote (state : State) (node : Location) : Prop := + exists nodeState, + Global.nodeState state node = some nodeState /\ + nodeState.votes ≠ [] + +def LaneAdvanced (state : State) (node : Location) : Prop := + exists nodeState, + Global.nodeState state node = some nodeState /\ + nodeState.timeoutState ≠ .gossiping + +theorem hasPhase_unique + {state : State} + {node : Location} + {first second : Phase} + (firstPhase : HasPhase state node first) + (secondPhase : HasPhase state node second) : + first = second := by + rcases firstPhase with ⟨firstState, firstFound, firstEq⟩ + rcases secondPhase with ⟨secondState, secondFound, secondEq⟩ + rw [firstFound] at secondFound + injection secondFound with stateEq + subst secondState + exact firstEq.symm.trans secondEq + +def Terminal (state : State) (node : Location) : Prop := + node ∈ state.restarts \/ node ∈ state.completed + +def CompletedOpen (state : State) (node : Location) : Prop := + node ∈ state.completed + +def AnnouncementsLive (state : State) : Prop := + forall envelope, envelope ∈ state.sent -> + envelope.payload = .iAmOpen -> + HasPhase state envelope.source .opening \/ + CompletedOpen state envelope.source + +def SentAnnouncementTo (state : State) (target : Location) : Prop := + exists envelope, + envelope ∈ state.sent /\ + envelope.target = target /\ + envelope.payload = .iAmOpen + +def JoiningAnnouncements (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + entry.2.phase = .joining -> + SentAnnouncementTo state entry.1 + +def OpenCompleted (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + entry.2.phase = .open -> + CompletedOpen state entry.1 + +def AdvancedNodesActive (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + entry.2.phase ≠ .gossiping -> + entry.1 ∈ state.active + +def OpenerWitness (state : State) : Prop := + exists node, + HasPhase state node .opening \/ + CompletedOpen state node + +def OnlyOpenerCompletesFrom + {config : Config} + (execution : Execution config) + (start : Nat) + (opener : Location) : Prop := + forall n node, + start <= n -> + CompletedOpen (execution.states n) node -> + node = opener + +def QuorumOnlyCompletions + {config : Config} + (execution : Execution config) : Prop := + forall n node, + CompletedOpen (execution.states n) node -> + QuorumOpened (execution.states n) node + +def SentAnnouncement + (state : State) + (source target : Location) : Prop := + exists envelope, + envelope ∈ state.sent /\ + envelope.source = source /\ + envelope.target = target /\ + envelope.payload = .iAmOpen + +def BroadcastBeforeCompletion + {config : Config} + (execution : Execution config) : Prop := + forall n opener, + CompletedOpen (execution.states n) opener -> + forall target, target ∈ (execution.states n).active -> + target ≠ opener -> + SentAnnouncement (execution.states n) opener target + +def AnnouncementsResolved (state : State) : Prop := + forall envelope, envelope ∈ state.sent -> + envelope.payload = .iAmOpen -> + envelope ∈ state.network \/ + Terminal state envelope.target \/ + HasPhase state envelope.target .opening + +def Enabled (config : Config) (state : State) (action : Action) : Prop := + exists nextState, next config state action = some nextState + +def LaneValid (state : NodeState) : Prop := + (state.phase = .gossiping -> + state.timeoutState = .gossiping) /\ + (state.phase = .voting -> + state.timeoutState = .gossiping \/ + state.timeoutState = .voting) /\ + (state.phase = .opening -> + state.timeoutState = .gossiping \/ + state.timeoutState = .voting \/ + state.timeoutState = .opening) /\ + (state.phase = .gossiping -> + state.chosen = none) + +def NodeLanesValid (state : State) : Prop := + forall entry, entry ∈ state.system.nodes -> + LaneValid entry.2 + +theorem step_preserves_lane + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (valid : LaneValid state) : + LaneValid (step config state event).state := by + cases event + all_goals try cases_type Validation + all_goals + simp [LaneValid, step, rejected, advance, advanceTimeoutLane, + advanceTimeoutState, validTimeout] at valid ⊢ + all_goals repeat first | split | simp_all | aesop + +theorem step_preserves_advanced_lane + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (advanced : state.timeoutState ≠ .gossiping) : + (step config state event).state.timeoutState ≠ .gossiping := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState] at advanced ⊢ + all_goals repeat first | split | simp_all + +theorem systemStep_preserves_lanes + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (valid : + forall entry, entry ∈ before.nodes -> + LaneValid entry.2) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + LaneValid entry.2 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · apply step_preserves_lane config node event + exact valid (key, node) (List.mem_of_find?_eq_some found) + · exact valid previous previousMember + +theorem initial_lanes_valid + (config : Config) + (active : List Location) : + NodeLanesValid (initial config active) := by + simp [NodeLanesValid, LaneValid, Global.initial, initialSystem, + initialNode] + +theorem next_preserves_lanes + {config : Config} + {before after : State} + {action : Action} + (valid : NodeLanesValid before) + (transition : next config before action = some after) : + NodeLanesValid after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_lanes valid systemStep + entry membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_lanes valid systemStep + entry membership + +theorem reachable_lanes_valid + {config : Config} + {state : State} + (reachable : Reachable config state) : + NodeLanesValid state := by + induction reachable with + | initial active valid nodup configured => + exact initial_lanes_valid config active + | step reachable transition valid => + exact next_preserves_lanes valid transition + +theorem nodeState_eq_of_mem + {state : State} + {node : Location} + {foundState : NodeState} + (keysNodup : (state.system.nodes.map Prod.fst).Nodup) + (membership : (node, foundState) ∈ state.system.nodes) : + Global.nodeState state node = some foundState := by + unfold Global.nodeState + cases found : + state.system.nodes.find? fun entry => entry.1 == node with + | none => + rw [List.find?_eq_none] at found + exact False.elim + (found (node, foundState) membership (by simp)) + | some entry => + have foundMember : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some found + have foundKey : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) found) + have same : entry = (node, foundState) := + eq_of_key_eq keysNodup foundMember membership foundKey + simp [same] + +theorem node_property_of_nodeState + {state : State} + {node : Location} + {foundState : NodeState} + {predicate : NodeState -> Prop} + (property : + forall entry, entry ∈ state.system.nodes -> + predicate entry.2) + (found : Global.nodeState state node = some foundState) : + predicate foundState := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + rw [←stateEq] + exact property entry (List.mem_of_find?_eq_some findEq) + +theorem deliver_target_state + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (transition : next config before (.deliver envelope) = some after) : + exists output, + Global.nodeState after envelope.target = some output.state /\ + systemStep config.protocol before.system envelope.target + (eventFor envelope) = some (after.system, output) := by + have afterWellFormed := + next_preserves_well_formed wellFormed transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] at afterWellFormed ⊢ + refine ⟨output, ?_, ?_⟩ + · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · simpa using systemStep + +theorem timeout_target_state + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.timeout target) = some after) : + exists output, + Global.nodeState after target = some output.state /\ + output.accepted = true /\ + systemStep config.protocol before.system target .timeout = + some (after.system, output) := by + have afterWellFormed := + next_preserves_well_formed wellFormed transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, accepted, stateEq⟩ + rw [←stateEq] at afterWellFormed ⊢ + refine ⟨output, ?_, accepted, ?_⟩ + · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · simpa using systemStep + +theorem systemStep_output_eq + {config : Protocol.Config} + {global : State} + {after : SystemState} + {target : Location} + {event : Event} + {state : NodeState} + {output : StepOutput} + (found : Global.nodeState global target = some state) + (transition : + systemStep config global.system target event = some (after, output)) : + output = step config state event := by + change + (do + let node <- Global.nodeState global target + let result := step config node event + pure ({ + nodes := replaceNode target result.state global.system.nodes + }, result)) = some (after, output) at transition + rw [found] at transition + simp at transition + exact transition.2.symm + +theorem completed_effect_recorded + {node : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (completed : .completed ∈ effects) : + node ∈ (recordEffects node nodeState effects state).completed := by + induction effects generalizing state with + | nil => simp at completed + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + rw [List.mem_cons] at completed + rcases completed with rfl | inTail + · apply mem_completed_recordEffects + simp [recordEffect] + · exact ih inTail + +theorem restart_effect_recorded + {node chosen : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (restart : .restart chosen ∈ effects) : + node ∈ (recordEffects node nodeState effects state).restarts := by + induction effects generalizing state with + | nil => simp at restart + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + rw [List.mem_cons] at restart + rcases restart with rfl | inTail + · apply mem_restarts_recordEffects + simp [recordEffect] + · exact ih inTail + +theorem mem_removeOne_or_eq + [BEq α] + [LawfulBEq α] + {member removed : α} + {values : List α} + (membership : member ∈ values) : + member ∈ removeOne removed values \/ member = removed := by + induction values with + | nil => simp at membership + | cons head tail ih => + rw [List.mem_cons] at membership + rcases membership with rfl | inTail + · by_cases equal : member = removed + · exact Or.inr equal + · exact Or.inl (by simp [removeOne, equal]) + · simp only [removeOne] + split + · exact Or.inl inTail + · rcases ih inTail with still | equal + · exact Or.inl (by simp [still]) + · exact Or.inr equal + +structure Fair + {config : Config} + (execution : Execution config) : Prop where + retry : + forall start node phase, + node ∈ (execution.states start).active -> + HasPhase (execution.states start) node phase -> + (phase = .gossiping \/ phase = .voting \/ phase = .opening) -> + Enabled config (execution.states start) (.retry node) -> + EventuallyFrom start (fun n => + Not (HasPhase (execution.states n) node phase) \/ + execution.actions n = .retry node) + delivery : + forall start envelope, + envelope ∈ (execution.states start).network -> + EventuallyFrom start (fun n => + execution.actions n = .deliver envelope) + timeout : + forall start node phase, + node ∈ (execution.states start).active -> + HasPhase (execution.states start) node phase -> + (phase = .gossiping \/ phase = .voting \/ phase = .opening) -> + Enabled config (execution.states start) (.timeout node) -> + EventuallyFrom start (fun n => + Not (HasPhase (execution.states n) node phase) \/ + execution.actions n = .timeout node) + openingTimeout : + forall start node, + node ∈ (execution.states start).active -> + HasPhase (execution.states start) node .opening -> + Enabled config (execution.states start) (.timeout node) -> + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node \/ + (HasPhase (execution.states n) node .opening /\ + execution.actions n = .timeout node)) + +theorem execution_reachable + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) : + forall n, Reachable config (execution.states n) := by + intro n + induction n with + | zero => exact initial + | succ n reachable => + exact Reachable.step reachable (execution.step_succ n) + +theorem execution_active_eq + {config : Config} + (execution : Execution config) : + forall n, (execution.states n).active = (execution.states 0).active := by + intro n + induction n with + | zero => rfl + | succ n activeEq => + exact (next_active_eq (execution.step_succ n)).trans activeEq + +theorem active_at + {config : Config} + (execution : Execution config) + {node : Location} + (active : node ∈ (execution.states 0).active) : + forall n, node ∈ (execution.states n).active := by + intro n + rw [execution_active_eq execution n] + exact active + +theorem recovered_for_configured + {config : Config} + (valid : config.Valid) + {node : Location} + (configured : node ∈ config.protocol.expectedLocations) : + exists txid, recoveredTxID config node = some txid := by + rw [←valid.2.2] at configured + rcases List.mem_map.mp configured with + ⟨entry, membership, keyEq⟩ + rcases entry with ⟨location, txid⟩ + simp at keyEq + subst location + refine ⟨txid, ?_⟩ + apply recoveredTxID_of_mem valid + exact membership + +theorem active_nodeState + {config : Config} + {state : State} + (wellFormed : WellFormed config state) + {node : Location} + (active : node ∈ state.active) : + exists nodeState, + Global.nodeState state node = some nodeState := by + have configured := wellFormed.activeConfigured node active + rw [←wellFormed.nodeKeys] at configured + rcases List.mem_map.mp configured with + ⟨entry, membership, keyEq⟩ + refine ⟨entry.2, ?_⟩ + apply nodeState_eq_of_mem wellFormed.nodeKeysNodup + rcases entry with ⟨location, nodeState⟩ + simp at keyEq + subst location + exact membership + +theorem retryMessages_self_gossip + {config : Config} + {node : Location} + {state : NodeState} + {txid : TxID} + (phase : state.phase = .gossiping) + (configured : node ∈ config.protocol.expectedLocations) + (recovered : recoveredTxID config node = some txid) : + { + source := node + target := node + payload := Payload.gossip txid + sourceState := state + } ∈ retryMessages config node state := by + rw [retryMessages, List.mem_filterMap] + refine ⟨.sendGossip node, ?_, ?_⟩ + · simpa [step, phase] using configured + · simp [messageForEffect, recovered] + +theorem retryMessages_vote + {config : Config} + {node target : Location} + {state : NodeState} + (phase : state.phase = .voting) + (chosen : state.chosen = some target) : + { + source := node + target + payload := Payload.vote + sourceState := state + } ∈ retryMessages config node state := by + rw [retryMessages, List.mem_filterMap] + refine ⟨.sendVote target, ?_, rfl⟩ + simp [step, phase, chosen] + +theorem retry_iamopen_state + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) + (announcement : envelope.payload = .iAmOpen) : + envelope.sourceState.phase = .opening := by + rcases valid_envelope_effect valid with + ⟨effect, member, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] at announcement + contradiction + | sendVote target => + simp [messageForEffect] at created + rw [←created] at announcement + contradiction + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at announcement ⊢ + cases phase : envelope.sourceState.phase + case opening => rfl + case voting => + cases chosen : envelope.sourceState.chosen <;> + simp [step, phase, chosen] at member + all_goals simp [step, phase] at member + | opening kind => simp [messageForEffect] at created + | restart chosen => simp [messageForEffect] at created + | completed => simp [messageForEffect] at created + | rejected reason => simp [messageForEffect] at created + +def acceptedIAmOpenSource : Event -> Option Location + | .receiveIAmOpen source .accepted => some source + | _ => none + +theorem step_joining_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (joining : (step config state event).state.phase = .joining) : + state.phase = .joining \/ + exists source, acceptedIAmOpenSource event = some source := by + cases event + all_goals try cases_type Validation + all_goals + simp [acceptedIAmOpenSource, step, rejected, advance, + advanceTimeoutLane] at joining ⊢ + all_goals + repeat first | split at joining | split | simp_all | aesop + +theorem step_open_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (opened : (step config state event).state.phase = .open) : + state.phase = .open \/ + .completed ∈ (step config state event).effects := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opened ⊢ + all_goals + repeat first | split at opened | split | simp_all | aesop + +theorem iamopen_delivery_outcome + (config : Protocol.Config) + (state : NodeState) + (source : Location) : + let output := step config state (.receiveIAmOpen source .accepted) + output.state.phase = .opening \/ + output.state.phase = .open \/ + exists chosen, .restart chosen ∈ output.effects := by + cases phase : state.phase <;> + simp [step, phase, rejected, advance, advanceTimeoutLane] + +theorem iamopen_open_predecessor + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (opened : + (step config state (.receiveIAmOpen source .accepted)).state.phase = + .open) : + state.phase = .open := by + cases phase : state.phase <;> + simp [step, phase, rejected, advance, advanceTimeoutLane] at opened + rfl + +theorem eventFor_iamopen_source + {envelope : Envelope} + {source : Location} + (accepted : + acceptedIAmOpenSource (eventFor envelope) = some source) : + envelope.payload = .iAmOpen /\ + envelope.source = source := by + cases payload : envelope.payload <;> + simp_all [eventFor, acceptedIAmOpenSource] + +theorem retry_gossip_enabled + {config : Config} + {state : State} + {node : Location} + (valid : config.Valid) + (wellFormed : WellFormed config state) + (active : node ∈ state.active) + (phase : HasPhase state node .gossiping) : + Enabled config state (.retry node) := by + rcases phase with ⟨nodeState, found, gossiping⟩ + have configured := wellFormed.activeConfigured node active + rcases recovered_for_configured valid configured with + ⟨txid, recovered⟩ + have message := + retryMessages_self_gossip gossiping configured recovered + have messagesNonempty : + retryMessages config node nodeState ≠ [] := by + intro empty + rw [empty] at message + simp at message + refine ⟨{ + state with + network := state.network ++ retryMessages config node nodeState + sent := state.sent ++ retryMessages config node nodeState + }, ?_⟩ + simp [next, active, found, messagesNonempty] + +theorem retry_voting_enabled + {config : Config} + {state : State} + {node target : Location} + {nodeState : NodeState} + (active : node ∈ state.active) + (found : Global.nodeState state node = some nodeState) + (phase : nodeState.phase = .voting) + (chosen : nodeState.chosen = some target) : + Enabled config state (.retry node) := by + have message := retryMessages_vote (config := config) + (node := node) phase chosen + have messagesNonempty : + retryMessages config node nodeState ≠ [] := by + intro empty + rw [empty] at message + simp at message + refine ⟨{ + state with + network := state.network ++ retryMessages config node nodeState + sent := state.sent ++ retryMessages config node nodeState + }, ?_⟩ + simp [next, active, found, messagesNonempty] + +theorem delivery_enabled + {config : Config} + {state : State} + {envelope : Envelope} + (wellFormed : WellFormed config state) + (network : envelope ∈ state.network) + (targetActive : envelope.target ∈ state.active) : + Enabled config state (.deliver envelope) := by + rcases active_nodeState wellFormed targetActive with + ⟨targetState, found⟩ + let output := step config.protocol targetState (eventFor envelope) + let system : SystemState := { + nodes := replaceNode envelope.target output.state state.system.nodes + } + let delivered : State := { + state with + system + network := removeOne envelope state.network + } + have stepResult : + systemStep config.protocol state.system envelope.target + (eventFor envelope) = some (system, output) := by + change + (do + let node <- Global.nodeState state envelope.target + let result := step config.protocol node (eventFor envelope) + pure ({ + nodes := + replaceNode envelope.target result.state state.system.nodes + }, result)) = some (system, output) + rw [found] + rfl + refine + ⟨recordEffects envelope.target output.state output.effects delivered, ?_⟩ + simp [next, network, targetActive, stepResult, output, system, + delivered] + +theorem timeout_enabled_of_accepted + {config : Config} + {state : State} + {node : Location} + {nodeState : NodeState} + (active : node ∈ state.active) + (found : Global.nodeState state node = some nodeState) + (accepted : (step config.protocol nodeState .timeout).accepted = true) : + Enabled config state (.timeout node) := by + let output := step config.protocol nodeState .timeout + let system : SystemState := { + nodes := replaceNode node output.state state.system.nodes + } + have stepResult : + systemStep config.protocol state.system node .timeout = + some (system, output) := by + change + (do + let current <- Global.nodeState state node + let result := step config.protocol current .timeout + pure ({ + nodes := replaceNode node result.state state.system.nodes + }, result)) = some (system, output) + rw [found] + rfl + refine + ⟨recordEffects node output.state output.effects + { state with system }, ?_⟩ + simp [next, active, stepResult, accepted, output, system] + +theorem retry_gossip_enqueued + {config : Config} + {before after : State} + {node : Location} + (valid : config.Valid) + (wellFormed : WellFormed config before) + (phase : HasPhase before node .gossiping) + (transition : next config before (.retry node) = some after) : + exists envelope, + envelope ∈ after.network /\ + envelope.source = node /\ + envelope.target = node /\ + exists txid, envelope.payload = .gossip txid := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨active, sourceState, found, _, stateEq⟩ + rcases phase with ⟨phaseState, foundPhase, gossiping⟩ + have configured := + wellFormed.activeConfigured node active + rcases recovered_for_configured valid configured with + ⟨txid, recovered⟩ + rw [found] at foundPhase + injection foundPhase with stateEq' + subst phaseState + let envelope : Envelope := { + source := node + target := node + payload := .gossip txid + sourceState + } + have message : envelope ∈ retryMessages config node sourceState := + retryMessages_self_gossip gossiping configured recovered + rw [←stateEq] + exact + ⟨envelope, List.mem_append_right _ message, rfl, rfl, txid, rfl⟩ + +theorem retry_vote_enqueued + {config : Config} + {before after : State} + {node target : Location} + {nodeState : NodeState} + (found : Global.nodeState before node = some nodeState) + (phase : nodeState.phase = .voting) + (chosen : nodeState.chosen = some target) + (transition : next config before (.retry node) = some after) : + exists envelope, + envelope ∈ after.network /\ + envelope.source = node /\ + envelope.target = target /\ + envelope.payload = .vote := by + have message := retryMessages_vote (config := config) + (node := node) phase chosen + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, actualState, actualFound, _, stateEq⟩ + rw [found] at actualFound + injection actualFound with actualEq + subst actualState + let envelope : Envelope := { + source := node + target + payload := .vote + sourceState := nodeState + } + rw [←stateEq] + exact + ⟨envelope, List.mem_append_right _ message, rfl, rfl, rfl⟩ + +theorem insertGossip_nonempty + (source : Location) + (txid : TxID) + (gossips : List (Prod Location TxID)) : + insertGossip source txid gossips ≠ [] := by + unfold insertGossip + split + · rename_i present + intro empty + subst gossips + simp at present + · intro empty + have lengths := + (List.mergeSort_perm ((source, txid) :: gossips) + (fun left right => left.1 <= right.1)).length_eq + rw [empty] at lengths + simp at lengths + +theorem maximumGossip_some + {gossips : List (Prod Location TxID)} + (nonempty : gossips ≠ []) : + exists selected, maximumGossip gossips = some selected := by + cases gossips with + | nil => contradiction + | cons head tail => + exact ⟨tail.foldl selectMaximum head, rfl⟩ + +theorem gossip_receive_progress + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (txid : TxID) + (valid : LaneValid state) + (phase : state.phase = .gossiping) : + let output := + step config state (.receiveGossip source txid .accepted) + output.state.phase ≠ .gossiping \/ + output.state.gossips ≠ [] := by + have chosen := valid.2.2.2 phase + have nonempty := insertGossip_nonempty source txid state.gossips + obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty + simp [step, phase, chosen, rejected, advance, advanceTimeoutLane, + validTimeout] + repeat first | split | simp_all + +theorem gossip_timeout_progress + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .gossiping) + (accepted : (step config state .timeout).accepted = true) : + (step config state .timeout).state.phase = .voting := by + have lane := valid.1 phase + simp [step, phase, lane, rejected, advance, advanceTimeoutLane, + validTimeout] at accepted ⊢ + repeat first | split at accepted | split | simp_all + +theorem gossip_timeout_enabled_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .gossiping) + (nonempty : state.gossips ≠ []) : + (step config state .timeout).accepted = true := by + have lane := valid.1 phase + obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty + simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + maximum] + +theorem gossip_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (lanes : NodeLanesValid state) + (phase : HasPhase state node .gossiping) + (gossip : HasGossip state node) : + Enabled config state (.timeout node) := by + rcases phase with ⟨phaseState, foundPhase, gossiping⟩ + rcases gossip with ⟨gossipState, foundGossip, nonempty⟩ + rw [foundPhase] at foundGossip + injection foundGossip with stateEq + subst gossipState + have lane := node_property_of_nodeState lanes foundPhase + apply timeout_enabled_of_accepted active foundPhase + exact gossip_timeout_enabled_local config.protocol phaseState lane + gossiping nonempty + +def openingDistance : Phase -> Nat + | .gossiping => 3 + | .voting => 2 + | .opening => 1 + | .joining | .open => 0 + +theorem opening_timeout_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .opening) : + let output := step config state .timeout + (output.effects = [.completed] /\ output.state.phase = .open) \/ + (output.state.phase = .opening /\ + openingDistance output.state.timeoutState < + openingDistance state.timeoutState) := by + rcases valid.2.2.1 phase with lane | lane | lane + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + +theorem opening_step_distance_le + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (valid : LaneValid state) + (phase : state.phase = .opening) + (after : (step config state event).state.phase = .opening) : + openingDistance (step config state event).state.timeoutState <= + openingDistance state.timeoutState := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => + rcases opening_timeout_local config state valid phase with + done | progress + · rw [done.2] at after + contradiction + · exact Nat.le_of_lt progress.2 + | retry => simp [step] + +theorem opening_step_or_completed + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (phase : state.phase = .opening) : + (step config state event).state.phase = .opening \/ + ((step config state event).state.phase = .open /\ + .completed ∈ (step config state event).effects) := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + split <;> simp_all + | retry => simp [step, phase] + +theorem opening_non_timeout + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (phase : state.phase = .opening) + (notTimeout : event ≠ .timeout) : + (step config state event).state.phase = .opening /\ + (step config state event).state.timeoutState = + state.timeoutState := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => contradiction + | retry => exact ⟨phase, rfl⟩ + +theorem opening_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (phase : HasPhase state node .opening) : + Enabled config state (.timeout node) := by + rcases phase with ⟨nodeState, found, opening⟩ + apply timeout_enabled_of_accepted active found + simp [step, opening, advance, rejected] + repeat first | split | simp_all + +theorem timeout_opening_step + {config : Config} + {before after : State} + {node : Location} + {beforeState : NodeState} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (foundBefore : + Global.nodeState before node = some beforeState) + (opening : beforeState.phase = .opening) + (transition : next config before (.timeout node) = some after) : + CompletedOpen after node \/ + (exists nextState : NodeState, + Global.nodeState after node = some nextState /\ + nextState.phase = .opening /\ + openingDistance nextState.timeoutState < + openingDistance beforeState.timeoutState) := by + have lane : LaneValid beforeState := by + apply node_property_of_nodeState (predicate := LaneValid) + · exact lanes + · exact foundBefore + have timeoutResult : + ((step config.protocol beforeState .timeout).effects = + [.completed] /\ + (step config.protocol beforeState .timeout).state.phase = .open) \/ + ((step config.protocol beforeState .timeout).state.phase = + .opening /\ + openingDistance + (step config.protocol beforeState .timeout).state.timeoutState < + openingDistance beforeState.timeoutState) := + opening_timeout_local config.protocol beforeState lane opening + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + rw [←outputEq] at timeoutResult + rw [←stateEq] + rcases timeoutResult with completed | progress + · exact Or.inl (by + rcases completed with ⟨effects, _⟩ + rw [effects] + simp [CompletedOpen, recordEffects, recordEffect]) + · exact Or.inr + ⟨output.state, + (by + apply nodeState_eq_of_mem + · rw [recordEffects_system, + systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · rw [recordEffects_system] + exact systemStep_output_mem systemStep), + progress.1, + by simpa using progress.2⟩ + +theorem next_opening_progress + {config : Config} + {before after : State} + {node : Location} + {beforeState : NodeState} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (foundBefore : + Global.nodeState before node = some beforeState) + (opening : beforeState.phase = .opening) + (transition : next config before action = some after) : + CompletedOpen after node \/ + (exists afterState : NodeState, + Global.nodeState after node = some afterState /\ + afterState.phase = .opening /\ + openingDistance afterState.timeoutState <= + openingDistance beforeState.timeoutState) := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact Or.inr + ⟨beforeState, foundBefore, opening, Nat.le_refl _⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have preserved := + opening_non_timeout config.protocol beforeState + (eventFor envelope) opening + (by + cases payloadEq : envelope.payload <;> + simp [eventFor, payloadEq]) + rw [←outputEq] at preserved + exact Or.inr + ⟨output.state, foundAfter, preserved.1, + by rw [preserved.2]⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact Or.inr + ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_opening_step wellFormed lanes foundBefore + opening transition with + completed | ⟨nextState, foundAfter, nextOpening, distance⟩ + · exact Or.inl completed + · exact Or.inr + ⟨nextState, foundAfter, nextOpening, + Nat.le_of_lt distance⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact Or.inr + ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ + +theorem insertVote_nonempty + (source : Location) + (votes : List Location) : + insertVote source votes ≠ [] := by + unfold insertVote + split + · rename_i present + intro empty + subst votes + simp at present + · intro empty + have lengths := + (List.mergeSort_perm (source :: votes) + (fun left right => left <= right)).length_eq + rw [empty] at lengths + simp at lengths + +theorem step_preserves_nonempty_votes + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (nonempty : state.votes ≠ []) : + (step config state event).state.votes ≠ [] := by + rcases step_votes_shape config state event with + unchanged | ⟨source, _, changed⟩ + · rw [unchanged] + exact nonempty + · rw [changed] + exact insertVote_nonempty source state.votes + +theorem next_preserves_hasVote + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (vote : HasVote before node) + (transition : next config before action = some after) : + HasVote after node := by + rcases vote with ⟨beforeState, foundBefore, nonempty⟩ + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact ⟨beforeState, foundBefore, nonempty⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState (eventFor envelope) nonempty⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], nonempty⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState .timeout nonempty⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], nonempty⟩ + +theorem hasVote_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (vote : HasVote (execution.states start) node) : + HasVote (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact vote + | succ finish order vote => + exact next_preserves_hasVote + (reachable_well_formed + (execution_reachable execution initial finish)) + vote (execution.step_succ finish) + +theorem next_preserves_advanced_lane + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (advanced : LaneAdvanced before node) + (transition : next config before action = some after) : + LaneAdvanced after node := by + rcases advanced with ⟨beforeState, foundBefore, lane⟩ + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact ⟨beforeState, foundBefore, lane⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_advanced_lane + config.protocol beforeState (eventFor envelope) lane⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], lane⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_advanced_lane + config.protocol beforeState .timeout lane⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], lane⟩ + +theorem advanced_lane_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (advanced : LaneAdvanced (execution.states start) node) : + LaneAdvanced (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact advanced + | succ finish order advanced => + exact next_preserves_advanced_lane + (reachable_well_formed + (execution_reachable execution initial finish)) + advanced (execution.step_succ finish) + +theorem opening_progress_between + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + {startState : NodeState} + (order : start <= finish) + (foundStart : + Global.nodeState (execution.states start) node = some startState) + (openingStart : startState.phase = .opening) + (notCompleted : + Not (CompletedOpen (execution.states finish) node)) : + exists finishState : NodeState, + Global.nodeState (execution.states finish) node = some finishState /\ + finishState.phase = .opening /\ + openingDistance finishState.timeoutState <= + openingDistance startState.timeoutState := by + induction finish, order using Nat.le_induction with + | base => + exact + ⟨startState, foundStart, openingStart, Nat.le_refl _⟩ + | succ finish order ih => + have notCompletedBefore : + Not (CompletedOpen (execution.states finish) node) := by + intro completed + exact notCompleted + (next_completed_monotonic + (execution.step_succ finish) node completed) + rcases ih notCompletedBefore with + ⟨beforeState, foundBefore, openingBefore, distanceBefore⟩ + rcases next_opening_progress + (reachable_well_formed + (execution_reachable execution initial finish)) + (reachable_lanes_valid + (execution_reachable execution initial finish)) + foundBefore openingBefore (execution.step_succ finish) with + completed | + ⟨afterState, foundAfter, openingAfter, distanceAfter⟩ + · contradiction + · exact + ⟨afterState, foundAfter, openingAfter, + Nat.le_trans distanceAfter distanceBefore⟩ + +theorem deliver_gossip_progress + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (payload : exists txid, envelope.payload = .gossip txid) + (phase : HasPhase before envelope.target .gossiping) + (transition : next config before (.deliver envelope) = some after) : + Not (HasPhase after envelope.target .gossiping) \/ + HasGossip after envelope.target := by + rcases phase with ⟨beforeState, foundBefore, gossiping⟩ + rcases payload with ⟨txid, payload⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have lane := + node_property_of_nodeState lanes foundBefore + simp [eventFor, payload] at outputEq + have progress := + gossip_receive_progress config.protocol beforeState + envelope.source txid lane gossiping + rw [←outputEq] at progress + rcases progress with left | right + · exact Or.inl (by + intro stillGossiping + rcases stillGossiping with ⟨state, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst state + exact left phase) + · exact Or.inr ⟨output.state, foundAfter, right⟩ + +theorem timeout_gossip_progress + {config : Config} + {before after : State} + {node : Location} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (phase : HasPhase before node .gossiping) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .voting := by + rcases phase with ⟨beforeState, foundBefore, gossiping⟩ + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, accepted, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have lane := + node_property_of_nodeState lanes foundBefore + have voting := + gossip_timeout_progress config.protocol beforeState lane + gossiping (by simpa [outputEq] using accepted) + exact + ⟨output.state, foundAfter, by simpa [outputEq] using voting⟩ + +theorem vote_receive_progress + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (phase : state.phase = .voting) : + let output := step config state (.receiveVote source .accepted) + output.state.phase ≠ .voting \/ output.state.votes ≠ [] := by + have nonempty := insertVote_nonempty source state.votes + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + +theorem voting_timeout_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .voting) + (nonempty : state.votes ≠ []) : + let output := step config state .timeout + output.state.phase = .opening \/ + (output.state.phase = .voting /\ + output.state.timeoutState = .voting) := by + rcases valid.2.1 phase with lane | lane + · simp [step, phase, lane, rejected, advance, validTimeout, + advanceTimeoutLane, advanceTimeoutState] + repeat first | split | simp_all + · simp [step, phase, lane, nonempty, rejected, advance, validTimeout, + advanceTimeoutLane, advanceTimeoutState] + +theorem aligned_voting_timeout_opens + (config : Protocol.Config) + (state : NodeState) + (phase : state.phase = .voting) + (lane : state.timeoutState = .voting) + (nonempty : state.votes ≠ []) : + (step config state .timeout).state.phase = .opening := by + simp [step, phase, lane, nonempty, rejected, advance, validTimeout, + advanceTimeoutLane] + +theorem deliver_vote_progress + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (payload : envelope.payload = .vote) + (phase : HasPhase before envelope.target .voting) + (transition : next config before (.deliver envelope) = some after) : + Not (HasPhase after envelope.target .voting) \/ + HasVote after envelope.target := by + rcases phase with ⟨beforeState, foundBefore, voting⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + simp [eventFor, payload] at outputEq + have progress := + vote_receive_progress config.protocol beforeState + envelope.source voting + rw [←outputEq] at progress + rcases progress with left | right + · exact Or.inl (by + intro stillVoting + rcases stillVoting with ⟨state, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst state + exact left phase) + · exact Or.inr ⟨output.state, foundAfter, right⟩ + +theorem deliver_iamopen_resolves + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (openCompleted : OpenCompleted before) + (payload : envelope.payload = .iAmOpen) + (transition : next config before (.deliver envelope) = some after) : + Terminal after envelope.target \/ + HasPhase after envelope.target .opening := by + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + simp [eventFor, payload] at outputEq + have outcome := + iamopen_delivery_outcome config.protocol beforeState envelope.source + rw [←outputEq] at outcome + rw [←stateEq] + rcases outcome with opening | opened | ⟨chosen, restarted⟩ + · exact Or.inr + ⟨output.state, + by + apply nodeState_eq_of_mem + · rw [recordEffects_system, + systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · rw [recordEffects_system] + exact systemStep_output_mem systemStep, + opening⟩ + · have beforeOpen := + iamopen_open_predecessor config.protocol beforeState + envelope.source (by simpa [outputEq] using opened) + have completedBefore : CompletedOpen before envelope.target := by + rw [Global.nodeState, Option.map_eq_some_iff] at foundBefore + rcases foundBefore with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = envelope.target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == envelope.target) findEq) + rw [←keyEq] + apply openCompleted entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using beforeOpen + exact Or.inl (Or.inr + (mem_completed_recordEffects completedBefore)) + · exact Or.inl (Or.inl + (restart_effect_recorded restarted)) + +theorem voting_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (phase : HasPhase state node .voting) : + Enabled config state (.timeout node) := by + rcases phase with ⟨nodeState, found, voting⟩ + apply timeout_enabled_of_accepted active found + simp [step, voting, advance, rejected] + repeat first | split | simp_all + +theorem timeout_voting_step + {config : Config} + {before after : State} + {node : Location} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (phase : HasPhase before node .voting) + (vote : HasVote before node) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .opening \/ + (exists nextState : NodeState, + Global.nodeState after node = some nextState /\ + nextState.phase = .voting /\ + nextState.timeoutState = .voting /\ + nextState.votes ≠ []) := by + rcases phase with ⟨beforeState, foundBefore, voting⟩ + rcases vote with ⟨voteState, foundVote, nonempty⟩ + rw [foundBefore] at foundVote + injection foundVote with stateEq + subst voteState + have lane : LaneValid beforeState := by + apply node_property_of_nodeState (predicate := LaneValid) + · exact lanes + · exact foundBefore + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + have progress := + voting_timeout_local config.protocol beforeState lane voting nonempty + rw [←outputEq] at progress + rcases progress with opening | waiting + · exact Or.inl ⟨output.state, foundAfter, opening⟩ + · exact Or.inr + ⟨output.state, foundAfter, waiting.1, waiting.2, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState .timeout nonempty⟩ + +theorem aligned_timeout_voting_opens + {config : Config} + {before after : State} + {node : Location} + {nodeState : NodeState} + (wellFormed : WellFormed config before) + (found : Global.nodeState before node = some nodeState) + (phase : nodeState.phase = .voting) + (lane : nodeState.timeoutState = .voting) + (nonempty : nodeState.votes ≠ []) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .opening := by + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := systemStep_output_eq found systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact aligned_voting_timeout_opens config.protocol nodeState + phase lane nonempty⟩ + +theorem fair_gossip_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + {node : Location} + (active : node ∈ (execution.states start).active) + (phase : HasPhase (execution.states start) node .gossiping) : + EventuallyFrom start (fun n => + Not (HasPhase (execution.states n) node .gossiping)) := by + have reachable (n : Nat) := + execution_reachable execution initial n + have configValid := reachable_config_valid (reachable start) + have retryEnabled := + retry_gossip_enabled configValid + (reachable_well_formed (reachable start)) active phase + rcases fair.retry start node .gossiping active phase + (Or.inl rfl) retryEnabled with + ⟨retryAt, startRetry, leftGossip | retryAction⟩ + · exact ⟨retryAt, startRetry, leftGossip⟩ + · by_cases retryPhase : + HasPhase (execution.states retryAt) node .gossiping + · have retryStep : + next config (execution.states retryAt) (.retry node) = + some (execution.states (retryAt + 1)) := by + simpa [retryAction] using execution.step_succ retryAt + rcases retry_gossip_enqueued configValid + (reachable_well_formed (reachable retryAt)) + retryPhase retryStep with + ⟨envelope, pending, sourceEq, targetEq, txid, payload⟩ + rcases fair.delivery (retryAt + 1) envelope pending with + ⟨deliverAt, retryDeliver, deliverAction⟩ + by_cases deliverPhase : + HasPhase (execution.states deliverAt) node .gossiping + · have deliverStep : + next config (execution.states deliverAt) + (.deliver envelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + have delivered := + deliver_gossip_progress + (reachable_well_formed (reachable deliverAt)) + (reachable_lanes_valid (reachable deliverAt)) + ⟨txid, payload⟩ + (by simpa [targetEq] using deliverPhase) + deliverStep + rcases delivered with leftAfter | hasGossip + · exact + ⟨deliverAt + 1, by omega, by simpa [targetEq] using leftAfter⟩ + · by_cases afterPhase : + HasPhase (execution.states (deliverAt + 1)) node .gossiping + · have timeoutEnabled := + gossip_timeout_enabled + (config := config) + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + (reachable_lanes_valid (reachable (deliverAt + 1))) + afterPhase + (by simpa [targetEq] using hasGossip) + rcases fair.timeout (deliverAt + 1) node .gossiping + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + afterPhase (Or.inl rfl) timeoutEnabled with + ⟨timeoutAt, deliverTimeout, leftBeforeTimeout | timeoutAction⟩ + · exact ⟨timeoutAt, by omega, leftBeforeTimeout⟩ + · by_cases timeoutPhase : + HasPhase (execution.states timeoutAt) node .gossiping + · have timeoutStep : + next config (execution.states timeoutAt) + (.timeout node) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using + execution.step_succ timeoutAt + have voting := + timeout_gossip_progress + (reachable_well_formed (reachable timeoutAt)) + (reachable_lanes_valid (reachable timeoutAt)) + timeoutPhase timeoutStep + refine ⟨timeoutAt + 1, by omega, ?_⟩ + intro impossible + have phases := hasPhase_unique voting impossible + contradiction + · exact ⟨timeoutAt, by omega, timeoutPhase⟩ + · exact ⟨deliverAt + 1, by omega, afterPhase⟩ + · exact ⟨deliverAt, by omega, deliverPhase⟩ + · exact ⟨retryAt, startRetry, retryPhase⟩ + +theorem next_gossiping_predecessor + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (transition : next config before action = some after) + (afterGossip : HasPhase after node .gossiping) : + HasPhase before node .gossiping := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] at afterGossip + exact afterGossip + | deliver envelope => + by_cases target : node = envelope.target + · subst node + have details := transition + simp [next, Option.bind_eq_some_iff] at details + have targetActive := details.2.1 + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + rcases afterGossip with ⟨afterState, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst afterState + have outputEq := + systemStep_output_eq foundBefore systemStep + have beforePhase : beforeState.phase = .gossiping := by + by_contra notGossip + have notAfter := + step_preserves_non_gossiping config.protocol beforeState + (eventFor envelope) notGossip + rw [←outputEq] at notAfter + exact notAfter phase + exact ⟨beforeState, foundBefore, beforePhase⟩ + · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ + have unchanged := + deliver_other_node_eq target transition + rw [foundAfter] at unchanged + cases foundBefore : + Global.nodeState before node with + | none => simp [foundBefore] at unchanged + | some beforeState => + rw [foundBefore] at unchanged + injection unchanged with stateEq + subst beforeState + exact ⟨afterState, foundBefore, phase⟩ + | timeout target => + by_cases same : node = target + · subst node + have details := transition + simp [next, Option.bind_eq_some_iff] at details + have targetActive := details.1 + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + rcases afterGossip with ⟨afterState, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst afterState + have outputEq := + systemStep_output_eq foundBefore systemStep + have beforePhase : beforeState.phase = .gossiping := by + by_contra notGossip + have notAfter := + step_preserves_non_gossiping config.protocol beforeState + .timeout notGossip + rw [←outputEq] at notAfter + exact notAfter phase + exact ⟨beforeState, foundBefore, beforePhase⟩ + · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ + have unchanged := + timeout_other_node_eq same transition + rw [foundAfter] at unchanged + cases foundBefore : + Global.nodeState before node with + | none => simp [foundBefore] at unchanged + | some beforeState => + rw [foundBefore] at unchanged + injection unchanged with stateEq + subst beforeState + exact ⟨afterState, foundBefore, phase⟩ + +theorem not_gossiping_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (notGossip : + Not (HasPhase (execution.states start) node .gossiping)) : + Not (HasPhase (execution.states finish) node .gossiping) := by + induction finish, order using Nat.le_induction with + | base => exact notGossip + | succ finish order notGossip => + intro gossip + exact notGossip + (next_gossiping_predecessor + (reachable_well_formed + (execution_reachable execution initial finish)) + (execution.step_succ finish) gossip) + +theorem eventually_list + {predicate : Nat -> Location -> Prop} + {start : Nat} + (nodes : List Location) + (eventual : + forall node, node ∈ nodes -> + EventuallyFrom start (fun n => predicate n node)) + (monotonic : + forall node first second, + first <= second -> + predicate first node -> + predicate second node) : + EventuallyFrom start (fun n => + forall node, node ∈ nodes -> predicate n node) := by + revert eventual + induction nodes with + | nil => + intro eventual + exact ⟨start, Nat.le_refl start, by simp⟩ + | cons head tail ih => + intro eventual + rcases eventual head (by simp) with + ⟨headAt, startHead, headHolds⟩ + rcases ih + (fun node membership => eventual node (by simp [membership])) with + ⟨tailAt, startTail, tailHolds⟩ + refine + ⟨max headAt tailAt, by omega, ?_⟩ + intro node membership + rw [List.mem_cons] at membership + rcases membership with rfl | inTail + · exact monotonic _ headAt (max headAt tailAt) + (Nat.le_max_left _ _) headHolds + · exact monotonic node tailAt (max headAt tailAt) + (Nat.le_max_right _ _) (tailHolds node inTail) + +theorem fair_all_leave_gossip + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (start : Nat) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + Not (HasPhase (execution.states n) node .gossiping)) := by + apply eventually_list (execution.states start).active + · intro node active + by_cases phase : + HasPhase (execution.states start) node .gossiping + · exact fair_gossip_progress execution initial fair active phase + · exact ⟨start, Nat.le_refl start, phase⟩ + · intro node first second order notGossip + exact not_gossiping_mono execution initial order notGossip + +theorem terminal_mono_step + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (transition : next config before action = some after) + (terminal : Terminal before node) : + Terminal after node := by + rcases terminal with restarted | completed + · exact Or.inl (next_restarts_monotonic transition node restarted) + · exact Or.inr (next_completed_monotonic transition node completed) + +theorem terminal_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (terminal : Terminal (execution.states start) node) : + Terminal (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact terminal + | succ finish order terminal => + exact terminal_mono_step (execution.step_succ finish) terminal + +theorem completed_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (completed : CompletedOpen (execution.states start) node) : + CompletedOpen (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact completed + | succ finish order completed => + exact next_completed_monotonic + (execution.step_succ finish) node completed + +theorem quorumOpened_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (opened : QuorumOpened (execution.states start) node) : + QuorumOpened (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact opened + | succ finish order opened => + rcases opened with + ⟨opening, membership, openingNode, kind⟩ + exact + ⟨opening, + next_openings_monotonic + (execution.step_succ finish) opening membership, + openingNode, + kind⟩ + +theorem fair_opening_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + {node : Location} + (active : node ∈ (execution.states start).active) + (phase : HasPhase (execution.states start) node .opening) : + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node) := by + rcases phase with ⟨startState, foundStart, openingStart⟩ + have auxiliary : + forall distance start state, + openingDistance state.timeoutState = distance -> + node ∈ (execution.states start).active -> + Global.nodeState (execution.states start) node = some state -> + state.phase = .opening -> + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node) := by + intro distance + induction distance using Nat.strong_induction_on with + | h distance ih => + intro start state distanceEq active found opening + have enabled := + opening_timeout_enabled (config := config) + active ⟨state, found, opening⟩ + rcases fair.openingTimeout start node active + ⟨state, found, opening⟩ enabled with + ⟨timeoutAt, startTimeout, + completed | ⟨stillOpening, timeoutAction⟩⟩ + · exact ⟨timeoutAt, startTimeout, completed⟩ + · by_cases completedBefore : + CompletedOpen (execution.states timeoutAt) node + · exact ⟨timeoutAt, startTimeout, completedBefore⟩ + · rcases opening_progress_between execution initial startTimeout + found opening completedBefore with + ⟨timeoutState, foundTimeout, openingTimeout, + distanceTimeout⟩ + have timeoutStep : + next config (execution.states timeoutAt) + (.timeout node) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using execution.step_succ timeoutAt + rcases timeout_opening_step + (reachable_well_formed + (execution_reachable execution initial timeoutAt)) + (reachable_lanes_valid + (execution_reachable execution initial timeoutAt)) + foundTimeout openingTimeout timeoutStep with + completedAfter | + ⟨nextState, foundNext, openingNext, distanceNext⟩ + · exact ⟨timeoutAt + 1, by omega, completedAfter⟩ + · have nextLess : openingDistance nextState.timeoutState < + distance := by + rw [←distanceEq] + exact Nat.lt_of_lt_of_le distanceNext distanceTimeout + rcases ih (openingDistance nextState.timeoutState) + nextLess (timeoutAt + 1) nextState rfl + (by + rw [execution_active_eq execution (timeoutAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + foundNext openingNext with + ⟨completedAt, nextCompleted, completed⟩ + exact ⟨completedAt, by omega, completed⟩ + exact auxiliary (openingDistance startState.timeoutState) + start startState rfl active foundStart openingStart + +theorem initial_announcements_live + (config : Config) + (active : List Location) : + AnnouncementsLive (initial config active) := by + simp [AnnouncementsLive, Global.initial] + +theorem next_preserves_announcements_live + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (live : AnnouncementsLive before) + (transition : next config before action = some after) : + AnnouncementsLive after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · exact live envelope old payload + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have opening := retry_iamopen_state valid payload + have identity := retryMessages_source added + rw [identity.2] at opening + exact Or.inl + ⟨sourceState, + by simpa [identity.1] using found, + opening⟩ + | deliver delivered => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases live envelope membership payload with + opening | completed + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr completed + · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ + · exact Or.inr + (next_completed_monotonic transition envelope.source completed) + | timeout target => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases live envelope membership payload with + opening | completed + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr completed + · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ + · exact Or.inr + (next_completed_monotonic transition envelope.source completed) + +theorem reachable_announcements_live + {config : Config} + {state : State} + (reachable : Reachable config state) : + AnnouncementsLive state := by + induction reachable with + | initial active valid nodup configured => + exact initial_announcements_live config active + | step reachable transition live => + exact next_preserves_announcements_live + (reachable_well_formed reachable) + (reachable_lanes_valid reachable) + live transition + +theorem initial_announcements_resolved + (config : Config) + (active : List Location) : + AnnouncementsResolved (initial config active) := by + simp [AnnouncementsResolved, Global.initial] + +theorem next_preserves_announcements_resolved + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (openCompleted : OpenCompleted before) + (resolved : AnnouncementsResolved before) + (transition : next config before action = some after) : + AnnouncementsResolved after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · rcases resolved envelope old payload with + pending | terminal | opening + · exact Or.inl (List.mem_append_left _ pending) + · exact Or.inr (Or.inl terminal) + · exact Or.inr (Or.inr opening) + · exact Or.inl (List.mem_append_right _ added) + | deliver delivered => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases resolved envelope membership payload with + pending | terminal | opening + · rcases mem_removeOne_or_eq pending with remains | equal + · exact Or.inl (by + rw [←stateEq, recordEffects_network] + exact remains) + · subst envelope + rcases deliver_iamopen_resolves wellFormed openCompleted payload + transition with + terminal | opening + · exact Or.inr (Or.inl terminal) + · exact Or.inr (Or.inr opening) + · exact Or.inr (Or.inl + (terminal_mono_step transition terminal)) + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr (Or.inl (Or.inr completed)) + · exact Or.inr (Or.inr + ⟨afterState, foundAfter, phaseAfter⟩) + | timeout target => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases resolved envelope membership payload with + pending | terminal | opening + · exact Or.inl (by + rw [←stateEq, recordEffects_network] + exact pending) + · exact Or.inr (Or.inl + (terminal_mono_step transition terminal)) + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr (Or.inl (Or.inr completed)) + · exact Or.inr (Or.inr + ⟨afterState, foundAfter, phaseAfter⟩) + +theorem systemStep_preserves_joining_announcements + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (valid : JoiningAnnouncements beforeState) + (carry : + forall destination, + SentAnnouncementTo beforeState destination -> + SentAnnouncementTo afterState destination) + (introduced : + (exists source, acceptedIAmOpenSource event = some source) -> + SentAnnouncementTo afterState target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .joining -> + SentAnnouncementTo afterState entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership joining + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + rcases step_joining_origin config node event + (by simpa [atTarget, outputEq] using joining) with + old | received + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + rw [←keyEq] + apply carry + apply valid (key, node) + · rw [beforeSystem] + exact List.mem_of_find?_eq_some found + · exact old + · exact introduced received + · rename_i notTarget + apply carry + apply valid previous + · rw [beforeSystem] + exact previousMember + · simpa [notTarget] using joining + +theorem initial_joining_announcements + (config : Config) + (active : List Location) : + JoiningAnnouncements (initial config active) := by + simp [JoiningAnnouncements, Global.initial, initialSystem, initialNode] + +theorem next_preserves_joining_announcements + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (valid : JoiningAnnouncements before) + (transition : next config before action = some after) : + JoiningAnnouncements after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rcases valid entry membership joining with + ⟨envelope, sent, target, payload⟩ + exact + ⟨envelope, List.mem_append_left _ sent, target, payload⟩ + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨inNetwork, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall destination, + SentAnnouncementTo before destination -> + SentAnnouncementTo afterState destination := by + intro destination announcement + rcases announcement with + ⟨sentEnvelope, sent, target, payload⟩ + exact + ⟨sentEnvelope, by simpa [afterState] using sent, + target, payload⟩ + have introduced : + (exists source, + acceptedIAmOpenSource (eventFor envelope) = some source) -> + SentAnnouncementTo afterState envelope.target := by + rintro ⟨source, accepted⟩ + rcases eventFor_iamopen_source accepted with + ⟨payload, _⟩ + exact + ⟨envelope, + by + simp [afterState] + exact wellFormed.networkSent envelope inNetwork, + rfl, payload⟩ + exact systemStep_preserves_joining_announcements + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep + entry membership joining + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall destination, + SentAnnouncementTo before destination -> + SentAnnouncementTo afterState destination := by + intro destination announcement + rcases announcement with + ⟨sentEnvelope, sent, target, payload⟩ + exact + ⟨sentEnvelope, by simpa [afterState] using sent, + target, payload⟩ + have introduced : + (exists source, + acceptedIAmOpenSource Event.timeout = some source) -> + SentAnnouncementTo afterState target := by + rintro ⟨source, accepted⟩ + simp [acceptedIAmOpenSource] at accepted + exact systemStep_preserves_joining_announcements + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep + entry membership joining + +theorem reachable_joining_announcements + {config : Config} + {state : State} + (reachable : Reachable config state) : + JoiningAnnouncements state := by + induction reachable with + | initial active valid nodup configured => + exact initial_joining_announcements config active + | step reachable transition valid => + exact next_preserves_joining_announcements + (reachable_well_formed reachable) valid transition + +theorem systemStep_preserves_open_completed + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (valid : OpenCompleted beforeState) + (carry : + forall node, + CompletedOpen beforeState node -> + CompletedOpen afterState node) + (introduced : + .completed ∈ output.effects -> + CompletedOpen afterState target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .open -> + CompletedOpen afterState entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership opened + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + rcases step_open_origin config node event + (by simpa [atTarget, outputEq] using opened) with + old | completed + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + rw [←keyEq] + apply carry + apply valid (key, node) + · rw [beforeSystem] + exact List.mem_of_find?_eq_some found + · exact old + · rw [outputEq] at completed + exact introduced completed + · rename_i notTarget + apply carry + apply valid previous + · rw [beforeSystem] + exact previousMember + · simpa [notTarget] using opened + +theorem initial_open_completed + (config : Config) + (active : List Location) : + OpenCompleted (initial config active) := by + simp [OpenCompleted, Global.initial, initialSystem, initialNode] + +theorem next_preserves_open_completed + {config : Config} + {before after : State} + {action : Action} + (valid : OpenCompleted before) + (transition : next config before action = some after) : + OpenCompleted after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership opened + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall node, + CompletedOpen before node -> + CompletedOpen afterState node := by + intro node completed + apply mem_completed_recordEffects + exact completed + have introduced : + .completed ∈ output.effects -> + CompletedOpen afterState envelope.target := by + intro completed + exact completed_effect_recorded completed + exact systemStep_preserves_open_completed + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep entry membership opened + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership opened + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall node, + CompletedOpen before node -> + CompletedOpen afterState node := by + intro node completed + apply mem_completed_recordEffects + exact completed + have introduced : + .completed ∈ output.effects -> + CompletedOpen afterState target := by + intro completed + exact completed_effect_recorded completed + exact systemStep_preserves_open_completed + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep entry membership opened + +theorem reachable_open_completed + {config : Config} + {state : State} + (reachable : Reachable config state) : + OpenCompleted state := by + induction reachable with + | initial active valid nodup configured => + exact initial_open_completed config active + | step reachable transition valid => + exact next_preserves_open_completed valid transition + +theorem reachable_announcements_resolved + {config : Config} + {state : State} + (reachable : Reachable config state) : + AnnouncementsResolved state := by + induction reachable with + | initial active valid nodup configured => + exact initial_announcements_resolved config active + | step reachable transition resolved => + exact next_preserves_announcements_resolved + (reachable_well_formed reachable) + (reachable_lanes_valid reachable) + (reachable_open_completed reachable) + resolved transition + +theorem open_node_completed + {state : State} + {node : Location} + {nodeState : NodeState} + (valid : OpenCompleted state) + (found : Global.nodeState state node = some nodeState) + (opened : nodeState.phase = .open) : + CompletedOpen state node := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply valid entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using opened + +theorem joining_node_announcement + {state : State} + {node : Location} + {nodeState : NodeState} + (valid : JoiningAnnouncements state) + (found : Global.nodeState state node = some nodeState) + (joining : nodeState.phase = .joining) : + SentAnnouncementTo state node := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply valid entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using joining + +theorem openerWitness_of_later_phase + {config : Config} + {state : State} + {node : Location} + (reachable : Reachable config state) + (active : node ∈ state.active) + (notGossip : Not (HasPhase state node .gossiping)) + (notVoting : Not (HasPhase state node .voting)) : + OpenerWitness state := by + rcases active_nodeState (reachable_well_formed reachable) active with + ⟨nodeState, found⟩ + cases phase : nodeState.phase with + | gossiping => + exact False.elim + (notGossip ⟨nodeState, found, phase⟩) + | voting => + exact False.elim + (notVoting ⟨nodeState, found, phase⟩) + | opening => + exact ⟨node, Or.inl ⟨nodeState, found, phase⟩⟩ + | joining => + rcases joining_node_announcement + (reachable_joining_announcements reachable) + found phase with + ⟨envelope, sent, target, payload⟩ + rcases reachable_announcements_live reachable + envelope sent payload with + opening | completed + · exact ⟨envelope.source, Or.inl opening⟩ + · exact ⟨envelope.source, Or.inr completed⟩ + | «open» => + exact + ⟨node, Or.inr + (open_node_completed + (reachable_open_completed reachable) found phase)⟩ + +theorem openerWitness_after_leave_voting + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start later : Nat} + {node : Location} + (order : start <= later) + (allPastGossip : + forall activeNode, + activeNode ∈ (execution.states start).active -> + Not (HasPhase (execution.states start) + activeNode .gossiping)) + (active : node ∈ (execution.states later).active) + (notVoting : + Not (HasPhase (execution.states later) node .voting)) : + OpenerWitness (execution.states later) := by + have activeStart : node ∈ (execution.states start).active := by + rw [execution_active_eq execution later] at active + rw [execution_active_eq execution start] + exact active + have notGossip := + not_gossiping_mono execution initial order + (allPastGossip node activeStart) + exact openerWitness_of_later_phase + (execution_reachable execution initial later) + active notGossip notVoting + +theorem systemStep_preserves_advanced_active + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {active : List Location} + (valid : + forall entry, entry ∈ before.nodes -> + entry.2.phase ≠ .gossiping -> + entry.1 ∈ active) + (targetActive : target ∈ active) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase ≠ .gossiping -> + entry.1 ∈ active := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership advanced + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · exact targetActive + · rename_i notTarget + exact valid previous previousMember + (by simpa [notTarget] using advanced) + +theorem initial_advanced_active + (config : Config) + (active : List Location) : + AdvancedNodesActive (initial config active) := by + simp [AdvancedNodesActive, Global.initial, initialSystem, initialNode] + +theorem next_preserves_advanced_active + {config : Config} + {before after : State} + {action : Action} + (valid : AdvancedNodesActive before) + (transition : next config before action = some after) : + AdvancedNodesActive after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership advanced + rw [recordEffects_system] at membership + simpa using + systemStep_preserves_advanced_active + valid targetActive systemStep entry membership advanced + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨targetActive, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership advanced + rw [recordEffects_system] at membership + simpa using + systemStep_preserves_advanced_active + valid targetActive systemStep entry membership advanced + +theorem reachable_advanced_active + {config : Config} + {state : State} + (reachable : Reachable config state) : + AdvancedNodesActive state := by + induction reachable with + | initial active valid nodup configured => + exact initial_advanced_active config active + | step reachable transition valid => + exact next_preserves_advanced_active valid transition + +theorem hasPhase_active + {config : Config} + {state : State} + {node : Location} + {phase : Phase} + (reachable : Reachable config state) + (hasPhase : HasPhase state node phase) + (advancedPhase : phase ≠ .gossiping) : + node ∈ state.active := by + rcases hasPhase with ⟨nodeState, found, phaseEq⟩ + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply reachable_advanced_active reachable entry + (List.mem_of_find?_eq_some findEq) + rw [stateEq, phaseEq] + exact advancedPhase + +theorem fair_opener_witness + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + (activeNonempty : (execution.states start).active ≠ []) + (allPastGossip : + forall node, node ∈ (execution.states start).active -> + Not (HasPhase (execution.states start) node .gossiping)) : + EventuallyFrom start (fun n => + OpenerWitness (execution.states n)) := by + obtain ⟨voter, voterActive⟩ := + List.exists_mem_of_ne_nil _ activeNonempty + by_cases voting : + HasPhase (execution.states start) voter .voting + · rcases voting with ⟨voterState, foundVoter, voterVoting⟩ + have selectionProperty := + node_property_of_nodeState + (predicate := fun state => + state.phase = .voting -> NodeVotingSelection state) + (reachable_quorum_invariant + (execution_reachable execution initial start)).votingSelections + foundVoter + rcases selectionProperty voterVoting with + ⟨target, txid, chosen, maximum⟩ + have retryEnabled := + retry_voting_enabled (config := config) + voterActive foundVoter voterVoting chosen + rcases fair.retry start voter .voting voterActive + ⟨voterState, foundVoter, voterVoting⟩ + (Or.inr (Or.inl rfl)) retryEnabled with + ⟨retryAt, startRetry, leftVoting | retryAction⟩ + · exact + ⟨retryAt, startRetry, + openerWitness_after_leave_voting execution initial + startRetry allPastGossip + (by + rw [execution_active_eq execution retryAt] + rw [execution_active_eq execution start] at voterActive + exact voterActive) + leftVoting⟩ + · by_cases retryVoting : + HasPhase (execution.states retryAt) voter .voting + · rcases retryVoting with + ⟨retryState, foundRetry, votingRetry⟩ + have retrySelectionProperty := + node_property_of_nodeState + (predicate := fun state => + state.phase = .voting -> NodeVotingSelection state) + (reachable_quorum_invariant + (execution_reachable execution initial retryAt)).votingSelections + foundRetry + rcases retrySelectionProperty votingRetry with + ⟨retryTarget, retryTxID, retryChosen, retryMaximum⟩ + have retryStep : + next config (execution.states retryAt) (.retry voter) = + some (execution.states (retryAt + 1)) := by + simpa [retryAction] using execution.step_succ retryAt + rcases retry_vote_enqueued foundRetry votingRetry retryChosen + retryStep with + ⟨voteEnvelope, pending, voteSource, voteTarget, votePayload⟩ + rcases fair.delivery (retryAt + 1) voteEnvelope pending with + ⟨deliverAt, retryDeliver, deliverAction⟩ + have deliverStep : + next config (execution.states deliverAt) + (.deliver voteEnvelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + have deliverDetails := deliverStep + simp [next, Option.bind_eq_some_iff] at deliverDetails + have targetActive : voteEnvelope.target ∈ + (execution.states deliverAt).active := + deliverDetails.2.1 + by_cases targetVoting : + HasPhase (execution.states deliverAt) + voteEnvelope.target .voting + · rcases deliver_vote_progress + (reachable_well_formed + (execution_reachable execution initial deliverAt)) + votePayload targetVoting deliverStep with + leftAfter | hasVote + · have activeAfter : voteEnvelope.target ∈ + (execution.states (deliverAt + 1)).active := by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] at targetActive + exact targetActive + exact + ⟨deliverAt + 1, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip activeAfter leftAfter⟩ + · by_cases votingAfter : + HasPhase (execution.states (deliverAt + 1)) + voteEnvelope.target .voting + · have activeAfter : voteEnvelope.target ∈ + (execution.states (deliverAt + 1)).active := by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] at targetActive + exact targetActive + have timeoutEnabled := + voting_timeout_enabled (config := config) + activeAfter votingAfter + rcases fair.timeout (deliverAt + 1) + voteEnvelope.target .voting activeAfter votingAfter + (Or.inr (Or.inl rfl)) timeoutEnabled with + ⟨timeoutAt, deliverTimeout, + leftBeforeTimeout | timeoutAction⟩ + · exact + ⟨timeoutAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution timeoutAt] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter) + leftBeforeTimeout⟩ + · by_cases votingAtTimeout : + HasPhase (execution.states timeoutAt) + voteEnvelope.target .voting + · have voteAtTimeout := + hasVote_mono execution initial deliverTimeout hasVote + have timeoutStep : + next config (execution.states timeoutAt) + (.timeout voteEnvelope.target) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using + execution.step_succ timeoutAt + rcases timeout_voting_step + (reachable_well_formed + (execution_reachable execution initial timeoutAt)) + (reachable_lanes_valid + (execution_reachable execution initial timeoutAt)) + votingAtTimeout voteAtTimeout timeoutStep with + opened | + ⟨waitingState, foundWaiting, waitingPhase, + waitingLane, waitingVotes⟩ + · exact + ⟨timeoutAt + 1, by omega, + ⟨voteEnvelope.target, Or.inl opened⟩⟩ + · have activeWaiting : voteEnvelope.target ∈ + (execution.states (timeoutAt + 1)).active := by + rw [execution_active_eq execution (timeoutAt + 1)] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter + have secondEnabled := + voting_timeout_enabled (config := config) + activeWaiting + ⟨waitingState, foundWaiting, waitingPhase⟩ + rcases fair.timeout (timeoutAt + 1) + voteEnvelope.target .voting activeWaiting + ⟨waitingState, foundWaiting, waitingPhase⟩ + (Or.inr (Or.inl rfl)) secondEnabled with + ⟨secondAt, firstSecond, + leftBeforeSecond | secondAction⟩ + · exact + ⟨secondAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution secondAt] + rw [execution_active_eq execution + (timeoutAt + 1)] at activeWaiting + exact activeWaiting) + leftBeforeSecond⟩ + · by_cases votingAtSecond : + HasPhase (execution.states secondAt) + voteEnvelope.target .voting + · rcases votingAtSecond with + ⟨secondState, foundSecond, secondPhase⟩ + have votesSecond := + hasVote_mono execution initial firstSecond + ⟨waitingState, foundWaiting, waitingVotes⟩ + rcases votesSecond with + ⟨voteState, foundVotes, secondVotes⟩ + rw [foundSecond] at foundVotes + injection foundVotes with voteStateEq + subst voteState + have advancedSecond := + advanced_lane_mono execution initial firstSecond + ⟨waitingState, foundWaiting, by simp [waitingLane]⟩ + rcases advancedSecond with + ⟨laneState, foundLane, advanced⟩ + rw [foundSecond] at foundLane + injection foundLane with laneStateEq + subst laneState + have laneValid : LaneValid secondState := by + apply node_property_of_nodeState + (predicate := LaneValid) + · exact reachable_lanes_valid + (execution_reachable execution initial secondAt) + · exact foundSecond + have secondLane : secondState.timeoutState = + .voting := by + rcases laneValid.2.1 secondPhase with + gossipLane | votingLane + · contradiction + · exact votingLane + have secondStep : + next config (execution.states secondAt) + (.timeout voteEnvelope.target) = + some (execution.states (secondAt + 1)) := by + simpa [secondAction] using + execution.step_succ secondAt + have opened := + aligned_timeout_voting_opens + (reachable_well_formed + (execution_reachable execution initial secondAt)) + foundSecond secondPhase secondLane secondVotes + secondStep + exact + ⟨secondAt + 1, by omega, + ⟨voteEnvelope.target, Or.inl opened⟩⟩ + · exact + ⟨secondAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution secondAt] + rw [execution_active_eq execution + (timeoutAt + 1)] at activeWaiting + exact activeWaiting) + votingAtSecond⟩ + · exact + ⟨timeoutAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution timeoutAt] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter) + votingAtTimeout⟩ + · exact + ⟨deliverAt + 1, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] + at targetActive + exact targetActive) + votingAfter⟩ + · exact + ⟨deliverAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip targetActive targetVoting⟩ + · exact + ⟨retryAt, startRetry, + openerWitness_after_leave_voting execution initial + startRetry allPastGossip + (by + rw [execution_active_eq execution retryAt] + rw [execution_active_eq execution start] at voterActive + exact voterActive) + retryVoting⟩ + · exact + ⟨start, Nat.le_refl start, + openerWitness_after_leave_voting execution initial + (Nat.le_refl start) allPastGossip voterActive voting⟩ + +theorem openerWitness_eventually_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + (witness : OpenerWitness (execution.states start)) : + EventuallyFrom start (fun n => + exists node, CompletedOpen (execution.states n) node) := by + rcases witness with ⟨node, opening | completed⟩ + · have active := + hasPhase_active (execution_reachable execution initial start) + opening (by simp) + rcases fair_opening_completes execution initial fair active opening with + ⟨completedAt, order, completed⟩ + exact ⟨completedAt, order, node, completed⟩ + · exact ⟨start, Nat.le_refl start, node, completed⟩ + +theorem fair_some_opener_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) := by + rcases fair_all_leave_gossip execution initial fair 0 with + ⟨pastGossipAt, _, allPastGossip⟩ + have nonemptyAt : + (execution.states pastGossipAt).active ≠ [] := by + rw [execution_active_eq execution pastGossipAt] + exact activeNonempty + have allPastAt : + forall node, node ∈ (execution.states pastGossipAt).active -> + Not (HasPhase (execution.states pastGossipAt) + node .gossiping) := by + intro node active + rw [execution_active_eq execution pastGossipAt] at active + exact allPastGossip node active + rcases fair_opener_witness execution initial fair nonemptyAt + allPastAt with + ⟨witnessAt, pastWitness, witness⟩ + rcases openerWitness_eventually_completes execution initial fair + witness with + ⟨completedAt, witnessCompleted, completed⟩ + exact ⟨completedAt, by omega, completed⟩ + +theorem fair_target_terminal_after_completion + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener target : Location} + (completed : CompletedOpen (execution.states start) opener) + (active : target ∈ (execution.states start).active) : + EventuallyFrom start (fun n => + Terminal (execution.states n) target) := by + by_cases same : target = opener + · subst target + exact ⟨start, Nat.le_refl start, Or.inr completed⟩ + · rcases broadcast start opener completed target active same with + ⟨envelope, sent, sourceEq, targetEq, payload⟩ + rcases reachable_announcements_resolved + (execution_reachable execution initial start) + envelope sent payload with + pending | terminal | opening + · rcases fair.delivery start envelope pending with + ⟨deliverAt, startDelivery, deliverAction⟩ + have deliverStep : + next config (execution.states deliverAt) (.deliver envelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + rcases deliver_iamopen_resolves + (reachable_well_formed + (execution_reachable execution initial deliverAt)) + (reachable_open_completed + (execution_reachable execution initial deliverAt)) + payload deliverStep with + terminal | targetOpening + · exact + ⟨deliverAt + 1, by omega, by simpa [targetEq] using terminal⟩ + · have openingActive := + hasPhase_active + (execution_reachable execution initial (deliverAt + 1)) + targetOpening (by simp) + rcases fair_opening_completes execution initial fair + openingActive targetOpening with + ⟨completedAt, deliveryCompleted, targetCompleted⟩ + exact + ⟨completedAt, by omega, + by simpa [targetEq] using (Or.inr targetCompleted)⟩ + · exact + ⟨start, Nat.le_refl start, by simpa [targetEq] using terminal⟩ + · have openingActive := + hasPhase_active + (execution_reachable execution initial start) + opening (by simp) + rcases fair_opening_completes execution initial fair + openingActive opening with + ⟨completedAt, startCompleted, targetCompleted⟩ + exact + ⟨completedAt, startCompleted, + by simpa [targetEq] using (Or.inr targetCompleted)⟩ + +theorem fair_all_terminal_after_completion + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (completed : CompletedOpen (execution.states start) opener) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + Terminal (execution.states n) node) := by + apply eventually_list (execution.states start).active + · intro node active + exact fair_target_terminal_after_completion + execution initial fair broadcast completed active + · intro node first second order terminal + exact terminal_mono execution order terminal + +theorem global_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) /\ + EventuallyFrom 0 (fun n => + forall node, node ∈ (execution.states 0).active -> + Terminal (execution.states n) node) := by + have completed := + fair_some_opener_completes execution initial fair activeNonempty + constructor + · exact completed + · rcases completed with + ⟨completedAt, _, opener, openerCompleted⟩ + rcases fair_all_terminal_after_completion execution initial fair + broadcast openerCompleted with + ⟨terminalAt, completedTerminal, allTerminal⟩ + refine ⟨terminalAt, by omega, ?_⟩ + intro node active + apply allTerminal node + rw [execution_active_eq execution completedAt] + exact active + +theorem single_completion_path_joins_others + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (completed : CompletedOpen (execution.states start) opener) + (onlyOpener : OnlyOpenerCompletesFrom execution start opener) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := by + apply eventually_list (execution.states start).active + · intro node active + by_cases same : node = opener + · exact ⟨start, Nat.le_refl start, Or.inl same⟩ + · rcases fair_target_terminal_after_completion + execution initial fair broadcast completed active with + ⟨terminalAt, startTerminal, terminal⟩ + rcases terminal with restarted | targetCompleted + · exact ⟨terminalAt, startTerminal, Or.inr restarted⟩ + · exact False.elim + (same + (onlyOpener terminalAt node startTerminal targetCompleted)) + · intro node first second order joined + rcases joined with same | restarted + · exact Or.inl same + · exact Or.inr + (by + induction second, order using Nat.le_induction with + | base => exact restarted + | succ second order restarted => + exact next_restarts_monotonic + (execution.step_succ second) node restarted) + +theorem quorum_path_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (opened : QuorumOpened (execution.states start) opener) + (completed : CompletedOpen (execution.states start) opener) + (quorumOnly : QuorumOnlyCompletions execution) : + QuorumOpened (execution.states start) opener /\ + CompletedOpen (execution.states start) opener /\ + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := by + have onlyOpener : + OnlyOpenerCompletesFrom execution start opener := by + intro n node startN nodeCompleted + exact quorum_opener_unique + (execution_reachable execution initial n) + (quorumOnly n node nodeCompleted) + (quorumOpened_mono execution startN opened) + exact + ⟨opened, completed, + single_completion_path_joins_others + execution initial fair broadcast completed onlyOpener⟩ + +end DisasterRecovery.Protocol.Global From 728ed1d14a877cb25319a6a6d9c671800cff513b Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:14:12 +0100 Subject: [PATCH 06/12] Add canonical Lean checks and CI Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- .github/workflows/README.md | 9 ++ .github/workflows/lean-disaster-recovery.yml | 46 ++++++ lean/disaster-recovery/AxiomChecks.lean | 21 +++ lean/disaster-recovery/CanonicalTests.lean | 145 +++++++++++++++++++ lean/disaster-recovery/README.md | 88 +++++++++++ lean/disaster-recovery/lakefile.toml | 5 + 6 files changed, 314 insertions(+) create mode 100644 .github/workflows/lean-disaster-recovery.yml create mode 100644 lean/disaster-recovery/AxiomChecks.lean create mode 100644 lean/disaster-recovery/CanonicalTests.lean create mode 100644 lean/disaster-recovery/README.md diff --git a/.github/workflows/README.md b/.github/workflows/README.md index 4eb03077223..ef1e552a362 100644 --- a/.github/workflows/README.md +++ b/.github/workflows/README.md @@ -101,6 +101,15 @@ Runs on pull requests that change `tla/` or `src/consensus/aft/raft.h`. File: `tla-shallow.yml` 3rd party dependencies: None +# Lean Disaster Recovery + +Builds the canonical Lean disaster recovery model, checks its proofs without +warnings or project `sorryAx` dependencies, and runs its executable canonical +behavior checks on relevant pull requests. + +File: `lean-disaster-recovery.yml` +3rd party dependencies: None + # Vendored Dependency Verification Verifies that files under `3rdparty/` match the Git commits or release artifacts diff --git a/.github/workflows/lean-disaster-recovery.yml b/.github/workflows/lean-disaster-recovery.yml new file mode 100644 index 00000000000..7ce96fd4523 --- /dev/null +++ b/.github/workflows/lean-disaster-recovery.yml @@ -0,0 +1,46 @@ +name: "Lean Disaster Recovery" + +on: + pull_request: + paths: + - "lean/disaster-recovery/**" + - ".github/workflows/lean-disaster-recovery.yml" + +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +permissions: read-all + +jobs: + canonical-model: + name: Canonical model and proofs + runs-on: ubuntu-latest + timeout-minutes: 30 + + steps: + - uses: actions/checkout@3d3c42e5aac5ba805825da76410c181273ba90b1 # v7.0.1 + + - name: Install Lean + shell: bash + run: | + set -euo pipefail + sudo apt-get update + sudo apt-get install -y elan + elan toolchain install "$(cat lean/disaster-recovery/lean-toolchain)" + + - name: Restore Mathlib cache + working-directory: lean/disaster-recovery + shell: bash + run: | + set -euo pipefail + lake exe cache get + + - name: Build and check canonical model + working-directory: lean/disaster-recovery + shell: bash + run: | + set -euo pipefail + lake build + lake env lean -DwarningAsError=true AxiomChecks.lean + lake exe canonical-checks diff --git a/lean/disaster-recovery/AxiomChecks.lean b/lean/disaster-recovery/AxiomChecks.lean new file mode 100644 index 00000000000..a962639129b --- /dev/null +++ b/lean/disaster-recovery/AxiomChecks.lean @@ -0,0 +1,21 @@ +import DisasterRecovery +import Lean.Elab.Command +import Lean.Util.CollectAxioms + +open Lean Elab Command + +elab "#assert_no_project_sorries" : command => do + let env <- getEnv + let mut offenders : Array Name := #[] + for (name, _) in env.constants.toList do + if name.toString.startsWith "DisasterRecovery" then + let axioms <- liftCoreM <| Lean.collectAxioms name + if axioms.contains (Name.mkSimple "sorryAx") then + offenders := offenders.push name + unless offenders.isEmpty do + throwError "declarations contain sorryAx: {offenders}" + +#assert_no_project_sorries + +def main : IO Unit := + pure () diff --git a/lean/disaster-recovery/CanonicalTests.lean b/lean/disaster-recovery/CanonicalTests.lean new file mode 100644 index 00000000000..451d0d6a6f7 --- /dev/null +++ b/lean/disaster-recovery/CanonicalTests.lean @@ -0,0 +1,145 @@ +import DisasterRecovery.Protocol.Temporal + +open DisasterRecovery.Protocol + +private def expect (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +private def eventsFor (config : Config) : List Event := + let messages := config.expectedLocations.flatMap fun source => + [ + .receiveGossip source { view := 0, seqno := source.length } .accepted, + .receiveGossip source { view := 0, seqno := source.length } .rejected, + .receiveVote source .accepted, + .receiveVote source .rejected, + .receiveIAmOpen source .accepted, + .receiveIAmOpen source .rejected + ] + messages ++ [.timeout, .retry] + +private def invariant (state : NodeState) : Bool := + let chosenReady := + if state.phase == .voting then state.chosen.isSome else true + let openingKind := + if state.phase == .opening || state.phase == .open then + state.openKind.isSome + else + true + let restartOnlyJoining := + if state.restartRequested then state.phase == .joining else true + chosenReady && openingKind && restartOnlyJoining + +private def enumerate (config : Config) (location : Location) : IO (Prod Nat Nat) := do + let initial := initialNode location + let mut states := #[initial] + let mut seen : Std.HashMap String Nat := {} + seen := seen.insert (stateKey initial) 0 + let mut cursor := 0 + let mut edges := 0 + while cursor < states.size do + let state := states[cursor]! + expect (invariant state) s!"canonical invariant failed: {stateKey state}" + for event in eventsFor config do + let next := (step config state event).state + edges := edges + 1 + let key := stateKey next + if !seen.contains key then + seen := seen.insert key states.size + states := states.push next + cursor := cursor + 1 + pure (states.size, edges) + +def main : IO UInt32 := do + let config : Config := { + instanceId := "canonical-tests" + expectedLocations := ["A", "B"] + } + expect config.isValid "canonical test configuration is invalid" + expect + (!({ instanceId := "invalid", expectedLocations := ["A", "A"] } : + Config).isValid) + "duplicate expected locations were accepted" + expect (voteQuorum config == 2) "two-node strict majority must be two" + + let initial := initialNode "A" + expect initial.gossips.isEmpty "canonical C++ state must start without gossip" + + let first := step config initial + (.receiveGossip "A" { view := 1, seqno := 10 } .accepted) + expect (first.state.phase == .gossiping) "one of two gossips advanced early" + let duplicate := step config first.state + (.receiveGossip "A" { view := 99, seqno := 99 } .accepted) + expect (duplicate.state == first.state) + "duplicate gossip source changed its recorded TxID" + let second := step config first.state + (.receiveGossip "B" { view := 2, seqno := 1 } .accepted) + expect (second.state.phase == .voting) "all expected gossips did not advance" + expect (second.state.chosen == some "B") "full TxID maximum was not chosen" + + let tiedA := step config initial + (.receiveGossip "A" { view := 2, seqno := 1 } .accepted) + let tiedB := step config tiedA.state + (.receiveGossip "B" { view := 2, seqno := 1 } .accepted) + expect (tiedB.state.chosen == some "B") + "location name did not break an equal TxID tie lexicographically" + + let frozen := step config second.state + (.receiveGossip "C" { view := 9, seqno := 9 } .accepted) + expect (!frozen.accepted && frozen.state == second.state) + "gossip did not freeze after choosing a node" + + let oneVote := step config second.state (.receiveVote "A" .accepted) + expect (oneVote.state.phase == .voting) "even-node quorum used legacy threshold" + let twoVotes := step config oneVote.state (.receiveVote "B" .accepted) + expect (twoVotes.state.phase == .opening) "strict voting quorum did not open" + expect (twoVotes.state.openKind == some .quorum) "quorum path mislabeled" + + let emptyVoting := { + initial with + phase := .voting + timeoutState := .voting + chosen := some "A" + } + let noVotes := step config emptyVoting .timeout + expect (noVotes.state == emptyVoting) + "aligned voting timeout with zero votes advanced" + + let oneVoteWaiting := { emptyVoting with votes := ["A"] } + let failover := step config oneVoteWaiting .timeout + expect (failover.state.phase == .opening) "failover vote did not open" + expect (failover.state.openKind == some .failover) "failover path mislabeled" + + let opening := { + twoVotes.state with + timeoutState := .opening + } + let complete := step config opening .timeout + expect (complete.state.phase == .open) "Opening timeout did not reach Open" + + let joining := step config initial + (.receiveIAmOpen "B" .accepted) + expect (joining.state.phase == .joining && joining.state.restartRequested) + "IAmOpen did not request joining restart" + + let retry := step config second.state .retry + expect + (retry.effects == + [.sendVote "B", .sendGossip "A", .sendGossip "B"]) + "Voting retry did not send vote before continuing gossip" + + let unexpectedConfig : Config := { + instanceId := "unexpected" + expectedLocations := ["A"] + } + let unexpected := step unexpectedConfig (initialNode "A") + (.receiveGossip "OUTSIDE" { view := 1, seqno := 1 } .accepted) + expect (unexpected.state.phase == .voting) + "model no longer exposes C++ acceptance of unexpected validated locations" + + let (oneStates, oneEdges) <- enumerate + { instanceId := "n1", expectedLocations := ["A"] } "A" + let (twoStates, twoEdges) <- enumerate config "A" + IO.println s!"canonical n=1: {oneStates} states, {oneEdges} event edges" + IO.println s!"canonical n=2: {twoStates} states, {twoEdges} event edges" + IO.println "all canonical semantic and proof checks passed" + pure 0 diff --git a/lean/disaster-recovery/README.md b/lean/disaster-recovery/README.md new file mode 100644 index 00000000000..c4621834fc6 --- /dev/null +++ b/lean/disaster-recovery/README.md @@ -0,0 +1,88 @@ +# Lean disaster recovery model + +This package contains the canonical Lean model of CCF's C++ recovery decision +protocol and its permanent safety and liveness proofs. It is pinned to Lean +4.28.0 and Mathlib `v4.28.0`. + +## Model + +`DisasterRecovery.Protocol.Model` models one protocol node. Its state machine +covers Gossiping, Voting, Opening, Joining, and Open, including the separate +timeout lane, retries, duplicate receives, strict-majority voting, failover, +restart, and completion. + +`DisasterRecovery.Protocol.Global` lifts the local transition function to a +system with active nodes, in-flight messages, immutable send history, and +terminal effects. Deliveries consume previously sent envelopes, so receives +cannot appear without a modeled send. + +The model follows the current C++ behavior in which a successfully validated +location is not rejected merely because it is absent from +`expectedLocations`. In particular, an accepted gossip from an unexpected +location can satisfy a size threshold. `CanonicalTests.lean` checks this +intentional accepted-unexpected-location behavior so that the implementation +discrepancy remains explicit. + +`Validation.accepted` and `Validation.rejected` are the boundary at which the +model receives the result of C++ quote and certificate validation. The model +does not formalize or prove the cryptography that produces that result. + +## Proof coverage and limits + +`DisasterRecovery.Protocol.Temporal` proves local safety properties and +Opening-to-Open progress under weak timeout fairness. + +`DisasterRecovery.Protocol.Invariants` proves global well-formedness, +message provenance, locality of transitions, append-only send history, and +monotonic terminal histories for reachable states. + +`DisasterRecovery.Protocol.Quorum` proves that votes are unique and backed by +prior sends, strict-majority quorums intersect, and any two quorum openings in +a reachable execution select the same opener. This safety result does not +require fairness. + +`DisasterRecovery.Protocol.Committed` proves TxID maximum properties and +committed-prefix preservation under two explicit premises: + +- `DurableCommit` requires at least one configured recovered ledger to cover + the committed TxID. +- `FullGossipSelection` requires a real sent vote whose selection snapshot + contains exactly the configured recovered TxIDs. + +A quorum opening alone does not imply `FullGossipSelection`, because voting may +begin after a gossip timeout. The committed-prefix result deliberately does not +derive or hide either durability or full-gossip evidence. + +`DisasterRecovery.Protocol.GlobalTemporal` proves conditional global progress. +Its theorems assume the relevant retry, message-delivery, and timeout fairness +premises. Progress for every active node additionally requires +`BroadcastBeforeCompletion`: an opener must send its `IAmOpen` announcement to +every other active node before it completes. Ordinary weak fairness does not +order actions that are enabled only for a finite interval, so this broadcast +ordering is a separate premise. The proofs do not construct a scheduler that +satisfies the fairness and broadcast-before-completion premises. + +## Files + +| File | Purpose | +| --- | --- | +| `DisasterRecovery/Protocol/Model.lean` | C++-aligned local transition model | +| `DisasterRecovery/Protocol/Temporal.lean` | Local safety and liveness | +| `DisasterRecovery/Protocol/Global.lean` | Distributed transition semantics | +| `DisasterRecovery/Protocol/Invariants.lean` | Reachability invariants | +| `DisasterRecovery/Protocol/Quorum.lean` | Quorum uniqueness | +| `DisasterRecovery/Protocol/Committed.lean` | Committed-prefix safety | +| `DisasterRecovery/Protocol/GlobalTemporal.lean` | Global liveness | +| `CanonicalTests.lean` | Executable canonical behavior checks | +| `AxiomChecks.lean` | Transitive project `sorryAx` rejection | + +## Validation + +Run from this directory: + +```console +lake exe cache get +lake build +lake env lean -DwarningAsError=true AxiomChecks.lean +lake exe canonical-checks +``` diff --git a/lean/disaster-recovery/lakefile.toml b/lean/disaster-recovery/lakefile.toml index df0456dcd8c..ac7b91709c4 100644 --- a/lean/disaster-recovery/lakefile.toml +++ b/lean/disaster-recovery/lakefile.toml @@ -3,6 +3,7 @@ version = "0.1.0" moreLeanArgs = ["-DwarningAsError=true"] defaultTargets = [ "DisasterRecovery", + "canonical-checks", ] [[require]] @@ -12,3 +13,7 @@ rev = "v4.28.0" [[lean_lib]] name = "DisasterRecovery" + +[[lean_exe]] +name = "canonical-checks" +root = "CanonicalTests" From ae6f36cec555fccb86e7f0fb1acfb55eda86b09a Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 10:14:40 +0100 Subject: [PATCH 07/12] Format Lean disaster recovery documentation Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- lean/disaster-recovery/README.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lean/disaster-recovery/README.md b/lean/disaster-recovery/README.md index c4621834fc6..130468ca386 100644 --- a/lean/disaster-recovery/README.md +++ b/lean/disaster-recovery/README.md @@ -64,17 +64,17 @@ satisfies the fairness and broadcast-before-completion premises. ## Files -| File | Purpose | -| --- | --- | -| `DisasterRecovery/Protocol/Model.lean` | C++-aligned local transition model | -| `DisasterRecovery/Protocol/Temporal.lean` | Local safety and liveness | -| `DisasterRecovery/Protocol/Global.lean` | Distributed transition semantics | -| `DisasterRecovery/Protocol/Invariants.lean` | Reachability invariants | -| `DisasterRecovery/Protocol/Quorum.lean` | Quorum uniqueness | -| `DisasterRecovery/Protocol/Committed.lean` | Committed-prefix safety | -| `DisasterRecovery/Protocol/GlobalTemporal.lean` | Global liveness | -| `CanonicalTests.lean` | Executable canonical behavior checks | -| `AxiomChecks.lean` | Transitive project `sorryAx` rejection | +| File | Purpose | +| ----------------------------------------------- | -------------------------------------- | +| `DisasterRecovery/Protocol/Model.lean` | C++-aligned local transition model | +| `DisasterRecovery/Protocol/Temporal.lean` | Local safety and liveness | +| `DisasterRecovery/Protocol/Global.lean` | Distributed transition semantics | +| `DisasterRecovery/Protocol/Invariants.lean` | Reachability invariants | +| `DisasterRecovery/Protocol/Quorum.lean` | Quorum uniqueness | +| `DisasterRecovery/Protocol/Committed.lean` | Committed-prefix safety | +| `DisasterRecovery/Protocol/GlobalTemporal.lean` | Global liveness | +| `CanonicalTests.lean` | Executable canonical behavior checks | +| `AxiomChecks.lean` | Transitive project `sorryAx` rejection | ## Validation From 6151e0c676a6ec3eee8daf29dccf77f8d9f42e9e Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Fri, 4 Sep 2026 16:13:44 +0100 Subject: [PATCH 08/12] Normalize Lean source line endings Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- .../DisasterRecovery/Protocol/Global.lean | 332 +-- .../DisasterRecovery/Protocol/Invariants.lean | 1798 ++++++++--------- 2 files changed, 1065 insertions(+), 1065 deletions(-) diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean index c29b83a1305..80e39567813 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Global.lean @@ -1,166 +1,166 @@ -import DisasterRecovery.Protocol.Model - -namespace DisasterRecovery.Protocol.Global - -structure Config where - protocol : Protocol.Config - recovered : List (Prod Location TxID) -deriving Repr, BEq - -def Config.Valid (config : Config) : Prop := - config.protocol.isValid = true /\ - config.protocol.expectedLocations.Nodup /\ - config.recovered.map Prod.fst = config.protocol.expectedLocations - -def recoveredTxID (config : Config) (source : Location) : Option TxID := - (config.recovered.find? fun entry => entry.1 == source).map Prod.snd - -inductive Payload where - | gossip (txid : TxID) - | vote - | iAmOpen -deriving Repr, BEq, ReflBEq, LawfulBEq - -structure Envelope where - source : Location - target : Location - payload : Payload - sourceState : NodeState -deriving Repr, BEq, ReflBEq, LawfulBEq - -structure Opening where - node : Location - kind : OpenKind - state : NodeState -deriving Repr, BEq - -structure State where - system : SystemState - active : List Location - network : List Envelope := [] - sent : List Envelope := [] - openings : List Opening := [] - restarts : List Location := [] - completed : List Location := [] -deriving Repr, BEq - -inductive Action where - | retry (source : Location) - | deliver (envelope : Envelope) - | timeout (target : Location) -deriving Repr, BEq - -def nodeState (state : State) (node : Location) : Option NodeState := - (state.system.nodes.find? fun entry => entry.1 == node).map Prod.snd - -def messageForEffect - (config : Config) - (source : Location) - (sourceState : NodeState) : Effect -> Option Envelope - | .sendGossip target => do - let txid <- recoveredTxID config source - pure { source, target, payload := .gossip txid, sourceState } - | .sendVote target => - some { source, target, payload := .vote, sourceState } - | .sendIAmOpen target => - some { source, target, payload := .iAmOpen, sourceState } - | _ => none - -def retryMessages - (config : Config) - (source : Location) - (sourceState : NodeState) : List Envelope := - (step config.protocol sourceState .retry).effects.filterMap - (messageForEffect config source sourceState) - -def Envelope.Valid (config : Config) (envelope : Envelope) : Prop := - envelope.sourceState.location = envelope.source /\ - envelope ∈ retryMessages config envelope.source envelope.sourceState - -def eventFor (envelope : Envelope) : Event := - match envelope.payload with - | .gossip txid => .receiveGossip envelope.source txid .accepted - | .vote => .receiveVote envelope.source .accepted - | .iAmOpen => .receiveIAmOpen envelope.source .accepted - -def removeOne [BEq α] (value : α) : List α -> List α - | [] => [] - | head :: tail => - if head == value then tail else head :: removeOne value tail - -def recordEffect - (node : Location) - (nodeState : NodeState) - (state : State) : Effect -> State - | .opening kind => - { - state with - openings := { node, kind, state := nodeState } :: state.openings - } - | .restart _ => - { state with restarts := node :: state.restarts } - | .completed => - { state with completed := node :: state.completed } - | _ => state - -def recordEffects - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : State := - effects.foldl (recordEffect node nodeState) state - -def initial (config : Config) (active : List Location) : State := { - system := initialSystem config.protocol - active -} - -def next (config : Config) (state : State) : Action -> Option State - | .retry source => do - guard (state.active.contains source) - let sourceState <- nodeState state source - let messages := retryMessages config source sourceState - guard (!messages.isEmpty) - pure { - state with - network := state.network ++ messages - sent := state.sent ++ messages - } - | .deliver envelope => do - guard (state.network.contains envelope) - guard (state.active.contains envelope.target) - let (system, output) <- - systemStep config.protocol state.system envelope.target - (eventFor envelope) - let delivered := { - state with - system - network := removeOne envelope state.network - } - pure - (recordEffects envelope.target output.state output.effects delivered) - | .timeout target => do - guard (state.active.contains target) - let (system, output) <- - systemStep config.protocol state.system target .timeout - guard output.accepted - pure - (recordEffects target output.state output.effects { state with system }) - -inductive Reachable (config : Config) : State -> Prop where - | initial - (active : List Location) - (valid : config.Valid) - (nodup : active.Nodup) - (configured : - forall node, node ∈ active -> - node ∈ config.protocol.expectedLocations) : - Reachable config (Global.initial config active) - | step - {state nextState : State} - {action : Action} - (reachable : Reachable config state) - (transition : next config state action = some nextState) : - Reachable config nextState - -end DisasterRecovery.Protocol.Global +import DisasterRecovery.Protocol.Model + +namespace DisasterRecovery.Protocol.Global + +structure Config where + protocol : Protocol.Config + recovered : List (Prod Location TxID) +deriving Repr, BEq + +def Config.Valid (config : Config) : Prop := + config.protocol.isValid = true /\ + config.protocol.expectedLocations.Nodup /\ + config.recovered.map Prod.fst = config.protocol.expectedLocations + +def recoveredTxID (config : Config) (source : Location) : Option TxID := + (config.recovered.find? fun entry => entry.1 == source).map Prod.snd + +inductive Payload where + | gossip (txid : TxID) + | vote + | iAmOpen +deriving Repr, BEq, ReflBEq, LawfulBEq + +structure Envelope where + source : Location + target : Location + payload : Payload + sourceState : NodeState +deriving Repr, BEq, ReflBEq, LawfulBEq + +structure Opening where + node : Location + kind : OpenKind + state : NodeState +deriving Repr, BEq + +structure State where + system : SystemState + active : List Location + network : List Envelope := [] + sent : List Envelope := [] + openings : List Opening := [] + restarts : List Location := [] + completed : List Location := [] +deriving Repr, BEq + +inductive Action where + | retry (source : Location) + | deliver (envelope : Envelope) + | timeout (target : Location) +deriving Repr, BEq + +def nodeState (state : State) (node : Location) : Option NodeState := + (state.system.nodes.find? fun entry => entry.1 == node).map Prod.snd + +def messageForEffect + (config : Config) + (source : Location) + (sourceState : NodeState) : Effect -> Option Envelope + | .sendGossip target => do + let txid <- recoveredTxID config source + pure { source, target, payload := .gossip txid, sourceState } + | .sendVote target => + some { source, target, payload := .vote, sourceState } + | .sendIAmOpen target => + some { source, target, payload := .iAmOpen, sourceState } + | _ => none + +def retryMessages + (config : Config) + (source : Location) + (sourceState : NodeState) : List Envelope := + (step config.protocol sourceState .retry).effects.filterMap + (messageForEffect config source sourceState) + +def Envelope.Valid (config : Config) (envelope : Envelope) : Prop := + envelope.sourceState.location = envelope.source /\ + envelope ∈ retryMessages config envelope.source envelope.sourceState + +def eventFor (envelope : Envelope) : Event := + match envelope.payload with + | .gossip txid => .receiveGossip envelope.source txid .accepted + | .vote => .receiveVote envelope.source .accepted + | .iAmOpen => .receiveIAmOpen envelope.source .accepted + +def removeOne [BEq α] (value : α) : List α -> List α + | [] => [] + | head :: tail => + if head == value then tail else head :: removeOne value tail + +def recordEffect + (node : Location) + (nodeState : NodeState) + (state : State) : Effect -> State + | .opening kind => + { + state with + openings := { node, kind, state := nodeState } :: state.openings + } + | .restart _ => + { state with restarts := node :: state.restarts } + | .completed => + { state with completed := node :: state.completed } + | _ => state + +def recordEffects + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : State := + effects.foldl (recordEffect node nodeState) state + +def initial (config : Config) (active : List Location) : State := { + system := initialSystem config.protocol + active +} + +def next (config : Config) (state : State) : Action -> Option State + | .retry source => do + guard (state.active.contains source) + let sourceState <- nodeState state source + let messages := retryMessages config source sourceState + guard (!messages.isEmpty) + pure { + state with + network := state.network ++ messages + sent := state.sent ++ messages + } + | .deliver envelope => do + guard (state.network.contains envelope) + guard (state.active.contains envelope.target) + let (system, output) <- + systemStep config.protocol state.system envelope.target + (eventFor envelope) + let delivered := { + state with + system + network := removeOne envelope state.network + } + pure + (recordEffects envelope.target output.state output.effects delivered) + | .timeout target => do + guard (state.active.contains target) + let (system, output) <- + systemStep config.protocol state.system target .timeout + guard output.accepted + pure + (recordEffects target output.state output.effects { state with system }) + +inductive Reachable (config : Config) : State -> Prop where + | initial + (active : List Location) + (valid : config.Valid) + (nodup : active.Nodup) + (configured : + forall node, node ∈ active -> + node ∈ config.protocol.expectedLocations) : + Reachable config (Global.initial config active) + | step + {state nextState : State} + {action : Action} + (reachable : Reachable config state) + (transition : next config state action = some nextState) : + Reachable config nextState + +end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean index 3fa11e0bcdd..dbe145561f1 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean @@ -1,899 +1,899 @@ -import DisasterRecovery.Protocol.Global -import Mathlib.Tactic - -namespace DisasterRecovery.Protocol.Global - -structure HistoriesActive (state : State) : Prop where - openings : - forall opening, opening ∈ state.openings -> - opening.node ∈ state.active - restarts : - forall node, node ∈ state.restarts -> - node ∈ state.active - completed : - forall node, node ∈ state.completed -> - node ∈ state.active - -structure WellFormed (config : Config) (state : State) : Prop where - nodeKeys : - state.system.nodes.map Prod.fst = - config.protocol.expectedLocations - nodeKeysNodup : (state.system.nodes.map Prod.fst).Nodup - nodeLocations : - forall entry, entry ∈ state.system.nodes -> - entry.2.location = entry.1 - activeNodup : state.active.Nodup - activeConfigured : - forall node, node ∈ state.active -> - node ∈ config.protocol.expectedLocations - sentValid : - forall envelope, envelope ∈ state.sent -> - envelope.Valid config - sentSourceActive : - forall envelope, envelope ∈ state.sent -> - envelope.source ∈ state.active - networkSent : - forall envelope, envelope ∈ state.network -> - envelope ∈ state.sent - historiesActive : HistoriesActive state - -theorem messageForEffect_source - {config : Config} - {source : Location} - {sourceState : NodeState} - {effect : Effect} - {envelope : Envelope} - (created : - messageForEffect config source sourceState effect = some envelope) : - envelope.source = source /\ - envelope.sourceState = sourceState := by - cases effect with - | sendGossip target => - cases found : recoveredTxID config source with - | none => - simp [messageForEffect, found] at created - | some txid => - simp [messageForEffect, found] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | sendVote target => - simp [messageForEffect] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | opening kind => - simp_all [messageForEffect] - | restart chosen => - simp_all [messageForEffect] - | completed => - simp_all [messageForEffect] - | rejected reason => - simp_all [messageForEffect] - -theorem retryMessages_source - {config : Config} - {source : Location} - {sourceState : NodeState} - {envelope : Envelope} - (created : - envelope ∈ retryMessages config source sourceState) : - envelope.source = source /\ - envelope.sourceState = sourceState := by - rw [retryMessages, List.mem_filterMap] at created - rcases created with ⟨effect, _, produced⟩ - exact messageForEffect_source produced - -theorem retryMessages_valid - (config : Config) - (source : Location) - (sourceState : NodeState) - (sourceLocation : sourceState.location = source) : - forall envelope, - envelope ∈ retryMessages config source sourceState -> - envelope.Valid config := by - intro envelope created - rcases retryMessages_source created with - ⟨sourceEq, stateEq⟩ - constructor - · rw [stateEq, sourceEq] - exact sourceLocation - · rw [sourceEq, stateEq] - exact created - -theorem valid_envelope_effect - {config : Config} - {envelope : Envelope} - (valid : envelope.Valid config) : - exists effect, - effect ∈ - (step config.protocol envelope.sourceState .retry).effects /\ - messageForEffect config envelope.source - envelope.sourceState effect = some envelope := by - rcases valid with ⟨_, created⟩ - rw [retryMessages, List.mem_filterMap] at created - exact created - -theorem valid_gossip_uses_recovered_txid - {config : Config} - {envelope : Envelope} - {txid : TxID} - (valid : envelope.Valid config) - (gossip : envelope.payload = .gossip txid) : - recoveredTxID config envelope.source = some txid := by - rcases valid_envelope_effect valid with - ⟨effect, _, created⟩ - cases effect with - | sendGossip target => - cases found : recoveredTxID config envelope.source with - | none => - simp [messageForEffect, found] at created - | some recovered => - simp [messageForEffect, found] at created - rw [←created] at gossip - injection gossip with same - subst recovered - rfl - | sendVote target => - simp [messageForEffect] at created - rw [←created] at gossip - contradiction - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] at gossip - contradiction - | opening kind => - simp [messageForEffect] at created - | restart chosen => - simp [messageForEffect] at created - | completed => - simp [messageForEffect] at created - | rejected reason => - simp [messageForEffect] at created - -theorem step_preserves_location - (config : Protocol.Config) - (state : NodeState) - (event : Event) : - (step config state event).state.location = state.location := by - cases event <;> - simp [step, rejected, advance, advanceTimeoutLane] - all_goals repeat first | split | simp_all - -theorem nodeState_location - {state : State} - {node : Location} - {foundState : NodeState} - (locations : - forall entry, entry ∈ state.system.nodes -> - entry.2.location = entry.1) - (found : nodeState state node = some foundState) : - foundState.location = node := by - rw [nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have membership : entry ∈ state.system.nodes := - List.mem_of_find?_eq_some findEq - have condition : (entry.1 == node) = true := - List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) findEq - have keyEq : entry.1 = node := beq_iff_eq.mp condition - rw [←stateEq, locations entry membership, keyEq] - -theorem initial_well_formed - (config : Config) - (active : List Location) - (valid : config.Valid) - (activeNodup : active.Nodup) - (activeConfigured : - forall node, node ∈ active -> - node ∈ config.protocol.expectedLocations) : - WellFormed config (initial config active) := by - constructor - · simp [Global.initial, initialSystem, Function.comp_def] - · simpa [Global.initial, initialSystem, Function.comp_def] using valid.2.1 - · simp [Global.initial, initialSystem, initialNode] - · exact activeNodup - · exact activeConfigured - · simp [Global.initial] - · simp [Global.initial] - · simp [Global.initial] - · constructor <;> simp [Global.initial] - -@[simp] -theorem recordEffects_active - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).active = state.active := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).active = - state.active - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_system - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).system = state.system := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).system = - state.system - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_network - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).network = state.network := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).network = - state.network - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_sent - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).sent = state.sent := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).sent = - state.sent - rw [ih] - cases effect <;> rfl - -theorem recordEffect_preserves_histories_active - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - (wellFormed : HistoriesActive state) - (nodeActive : node ∈ state.active) : - HistoriesActive (recordEffect node nodeState state effect) := by - rcases wellFormed with ⟨openings, restarts, completed⟩ - cases effect <;> - constructor <;> - simp_all [recordEffect] - -theorem recordEffects_preserves_histories_active - {node : Location} - {nodeState : NodeState} - {effects : List Effect} - {state : State} - (wellFormed : HistoriesActive state) - (nodeActive : node ∈ state.active) : - HistoriesActive (recordEffects node nodeState effects state) := by - induction effects generalizing state with - | nil => exact wellFormed - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - apply ih - · exact recordEffect_preserves_histories_active wellFormed nodeActive - · cases effect <;> simpa [recordEffect] using nodeActive - -theorem mem_of_mem_removeOne - [BEq α] - (value member : α) - (values : List α) : - member ∈ removeOne value values -> - member ∈ values := by - induction values with - | nil => simp [removeOne] - | cons head tail ih => - simp only [removeOne] - split - · exact List.mem_cons_of_mem head - · intro membership - rw [List.mem_cons] at membership ⊢ - exact membership.imp_right ih - -theorem mem_openings_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {opening : Opening} - (membership : opening ∈ state.openings) : - opening ∈ (recordEffect node nodeState state effect).openings := by - cases effect <;> simp_all [recordEffect] - -theorem mem_restarts_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {restart : Location} - (membership : restart ∈ state.restarts) : - restart ∈ (recordEffect node nodeState state effect).restarts := by - cases effect <;> simp_all [recordEffect] - -theorem mem_completed_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {completed : Location} - (membership : completed ∈ state.completed) : - completed ∈ (recordEffect node nodeState state effect).completed := by - cases effect <;> simp_all [recordEffect] - -theorem mem_openings_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {opening : Opening} - (membership : opening ∈ state.openings) : - opening ∈ (recordEffects node nodeState effects state).openings := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_openings_recordEffect membership) - -theorem mem_restarts_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {restart : Location} - (membership : restart ∈ state.restarts) : - restart ∈ (recordEffects node nodeState effects state).restarts := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_restarts_recordEffect membership) - -theorem mem_completed_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {completed : Location} - (membership : completed ∈ state.completed) : - completed ∈ (recordEffects node nodeState effects state).completed := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_completed_recordEffect membership) - -theorem replaceNode_keys - (target : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) : - (replaceNode target nextState nodes).map Prod.fst = - nodes.map Prod.fst := by - induction nodes with - | nil => rfl - | cons entry tail ih => - simp only [replaceNode, List.map_cons] - split - · - rename_i condition - have same : entry.1 = target := beq_iff_eq.mp condition - simp only [List.cons.injEq] - constructor - · exact same.symm - · simpa [replaceNode] using ih - · - simp only [List.cons.injEq, true_and] - simpa [replaceNode] using ih - -theorem replaceNode_locations - (target : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) - (locations : - forall entry, entry ∈ nodes -> - entry.2.location = entry.1) - (nextLocation : nextState.location = target) : - forall entry, entry ∈ replaceNode target nextState nodes -> - entry.2.location = entry.1 := by - intro entry membership - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · exact nextLocation - · exact locations previous previousMember - -theorem findNode_replaceNode_ne - (target other : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) - (different : other ≠ target) : - ((replaceNode target nextState nodes).find? - fun entry => entry.1 == other).map Prod.snd = - (nodes.find? fun entry => entry.1 == other).map Prod.snd := by - let replace : Prod Location NodeState -> Prod Location NodeState := - fun entry => - if entry.1 == target then (target, nextState) else entry - change - Option.map Prod.snd - (List.find? (fun entry => entry.1 == other) - (nodes.map replace)) = - Option.map Prod.snd - (List.find? (fun entry => entry.1 == other) nodes) - rw [List.find?_map] - have predicate : - ((fun entry : Prod Location NodeState => entry.1 == other) ∘ - replace) = - (fun entry => entry.1 == other) := by - funext entry - by_cases atTarget : entry.1 = target - · simp [replace, atTarget] - · simp [replace, atTarget] - rw [predicate] - cases found : - List.find? (fun entry : Prod Location NodeState => - entry.1 == other) nodes with - | none => simp - | some entry => - have condition : - (entry.1 == other) = true := - List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == other) found - have entryOther : entry.1 = other := - beq_iff_eq.mp condition - have notTarget : entry.1 ≠ target := by - simpa [entryOther] using different - simp [replace, notTarget] - -theorem systemStep_node_keys_eq - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (transition : - systemStep config before target event = some (after, output)) : - after.nodes.map Prod.fst = before.nodes.map Prod.fst := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with ⟨node, _, stateEq, _⟩ - rw [←stateEq] - exact replaceNode_keys target - (step config node event).state before.nodes - -theorem systemStep_preserves_node_locations - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (locations : - forall entry, entry ∈ before.nodes -> - entry.2.location = entry.1) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.location = entry.1 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, stateEq, _⟩ - rw [←stateEq] - apply replaceNode_locations - · exact locations - · calc - (step config node event).state.location = - node.location := step_preserves_location config node event - _ = key := - locations (key, node) (List.mem_of_find?_eq_some found) - _ = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - -theorem systemStep_other_node_eq - {config : Protocol.Config} - {before after : SystemState} - {target other : Location} - {event : Event} - {output : StepOutput} - (different : other ≠ target) - (transition : - systemStep config before target event = some (after, output)) : - (after.nodes.find? fun entry => entry.1 == other).map Prod.snd = - (before.nodes.find? fun entry => entry.1 == other).map Prod.snd := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with ⟨node, _, stateEq, _⟩ - rw [←stateEq] - exact findNode_replaceNode_ne target other - (step config node event).state before.nodes different - -theorem next_active_eq - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - after.active = before.active := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, _, system, output, _, rfl⟩ - simp - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, system, output, _, _, rfl⟩ - simp - -theorem next_node_keys_eq - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - after.system.nodes.map Prod.fst = - before.system.nodes.map Prod.fst := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, _, system, output, systemStep, rfl⟩ - simpa using systemStep_node_keys_eq systemStep - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, system, output, systemStep, _, rfl⟩ - simpa using systemStep_node_keys_eq systemStep - -theorem retry_system_eq - {config : Config} - {before after : State} - {source : Location} - (transition : next config before (.retry source) = some after) : - after.system = before.system := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - -theorem deliver_network_eq - {config : Config} - {before after : State} - {envelope : Envelope} - (transition : next config before (.deliver envelope) = some after) : - after.network = removeOne envelope before.network := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - simp - -theorem timeout_network_eq - {config : Config} - {before after : State} - {target : Location} - (transition : next config before (.timeout target) = some after) : - after.network = before.network := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - simp - -theorem deliver_other_node_eq - {config : Config} - {before after : State} - {envelope : Envelope} - {other : Location} - (different : other ≠ envelope.target) - (transition : next config before (.deliver envelope) = some after) : - nodeState after other = nodeState before other := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - simp only [nodeState, recordEffects_system] - exact systemStep_other_node_eq different systemStep - -theorem timeout_other_node_eq - {config : Config} - {before after : State} - {target other : Location} - (different : other ≠ target) - (transition : next config before (.timeout target) = some after) : - nodeState after other = nodeState before other := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - simp only [nodeState, recordEffects_system] - exact systemStep_other_node_eq different systemStep - -theorem next_sent_extends - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - exists added, after.sent = before.sent ++ added := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact ⟨retryMessages config source sourceState, rfl⟩ - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - refine ⟨[], ?_⟩ - simp - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - refine ⟨[], ?_⟩ - simp - -theorem next_openings_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall opening, opening ∈ before.openings -> - opening ∈ after.openings := by - intro opening membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_openings_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_openings_recordEffects - simpa using membership - -theorem next_restarts_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall restart, restart ∈ before.restarts -> - restart ∈ after.restarts := by - intro restart membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_restarts_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_restarts_recordEffects - simpa using membership - -theorem next_completed_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall completed, completed ∈ before.completed -> - completed ∈ after.completed := by - intro completed membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_completed_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_completed_recordEffects - simpa using membership - -theorem retry_preserves_well_formed - {config : Config} - {before after : State} - {source : Location} - (wellFormed : WellFormed config before) - (transition : next config before (.retry source) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨sourceActive, sourceState, found, _, stateEq⟩ - have sourceLocation : sourceState.location = source := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - constructor - · exact wellFormed.nodeKeys - · exact wellFormed.nodeKeysNodup - · exact wellFormed.nodeLocations - · exact wellFormed.activeNodup - · exact wellFormed.activeConfigured - · intro envelope membership - rw [List.mem_append] at membership - rcases membership with membership | membership - · exact wellFormed.sentValid envelope membership - · exact retryMessages_valid config source sourceState - sourceLocation envelope membership - · intro envelope membership - rw [List.mem_append] at membership - rcases membership with membership | membership - · exact wellFormed.sentSourceActive envelope membership - · rw [(retryMessages_source membership).1] - exact sourceActive - · intro envelope membership - rw [List.mem_append] at membership ⊢ - rcases membership with membership | membership - · exact Or.inl (wellFormed.networkSent envelope membership) - · exact Or.inr membership - · constructor - · exact wellFormed.historiesActive.openings - · exact wellFormed.historiesActive.restarts - · exact wellFormed.historiesActive.completed - -theorem deliver_preserves_well_formed - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (transition : next config before (.deliver envelope) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, targetActive, system, output, systemStep, stateEq⟩ - rw [←stateEq] - constructor - · simp only [recordEffects_system] - exact (systemStep_node_keys_eq systemStep).trans - wellFormed.nodeKeys - · rw [recordEffects_system, systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · simp only [recordEffects_system] - exact systemStep_preserves_node_locations - wellFormed.nodeLocations systemStep - · simpa using wellFormed.activeNodup - · simpa using wellFormed.activeConfigured - · intro sent membership - rw [recordEffects_sent] at membership - exact wellFormed.sentValid sent membership - · intro sent membership - rw [recordEffects_sent] at membership - rw [recordEffects_active] - exact wellFormed.sentSourceActive sent membership - · intro pending membership - rw [recordEffects_network] at membership - rw [recordEffects_sent] - exact wellFormed.networkSent pending - (mem_of_mem_removeOne envelope pending before.network membership) - · apply recordEffects_preserves_histories_active - · constructor - · simpa using wellFormed.historiesActive.openings - · simpa using wellFormed.historiesActive.restarts - · simpa using wellFormed.historiesActive.completed - · simpa using targetActive - -theorem timeout_preserves_well_formed - {config : Config} - {before after : State} - {target : Location} - (wellFormed : WellFormed config before) - (transition : next config before (.timeout target) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨targetActive, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - constructor - · simp only [recordEffects_system] - exact (systemStep_node_keys_eq systemStep).trans - wellFormed.nodeKeys - · rw [recordEffects_system, systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · simp only [recordEffects_system] - exact systemStep_preserves_node_locations - wellFormed.nodeLocations systemStep - · simpa using wellFormed.activeNodup - · simpa using wellFormed.activeConfigured - · intro sent membership - rw [recordEffects_sent] at membership - exact wellFormed.sentValid sent membership - · intro sent membership - rw [recordEffects_sent] at membership - rw [recordEffects_active] - exact wellFormed.sentSourceActive sent membership - · intro pending membership - rw [recordEffects_network] at membership - rw [recordEffects_sent] - exact wellFormed.networkSent pending membership - · apply recordEffects_preserves_histories_active - · constructor - · simpa using wellFormed.historiesActive.openings - · simpa using wellFormed.historiesActive.restarts - · simpa using wellFormed.historiesActive.completed - · simpa using targetActive - -theorem next_preserves_well_formed - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (transition : next config before action = some after) : - WellFormed config after := by - cases action with - | retry source => - exact retry_preserves_well_formed wellFormed transition - | deliver envelope => - exact deliver_preserves_well_formed wellFormed transition - | timeout target => - exact timeout_preserves_well_formed wellFormed transition - -theorem reachable_well_formed - {config : Config} - {state : State} - (reachable : Reachable config state) : - WellFormed config state := by - induction reachable with - | initial active valid nodup configured => - exact initial_well_formed config active valid nodup configured - | step reachable transition wellFormed => - exact next_preserves_well_formed wellFormed transition - -theorem reachable_config_valid - {config : Config} - {state : State} - (reachable : Reachable config state) : - config.Valid := by - induction reachable with - | initial active valid nodup configured => exact valid - | step reachable transition valid => exact valid - -end DisasterRecovery.Protocol.Global +import DisasterRecovery.Protocol.Global +import Mathlib.Tactic + +namespace DisasterRecovery.Protocol.Global + +structure HistoriesActive (state : State) : Prop where + openings : + forall opening, opening ∈ state.openings -> + opening.node ∈ state.active + restarts : + forall node, node ∈ state.restarts -> + node ∈ state.active + completed : + forall node, node ∈ state.completed -> + node ∈ state.active + +structure WellFormed (config : Config) (state : State) : Prop where + nodeKeys : + state.system.nodes.map Prod.fst = + config.protocol.expectedLocations + nodeKeysNodup : (state.system.nodes.map Prod.fst).Nodup + nodeLocations : + forall entry, entry ∈ state.system.nodes -> + entry.2.location = entry.1 + activeNodup : state.active.Nodup + activeConfigured : + forall node, node ∈ state.active -> + node ∈ config.protocol.expectedLocations + sentValid : + forall envelope, envelope ∈ state.sent -> + envelope.Valid config + sentSourceActive : + forall envelope, envelope ∈ state.sent -> + envelope.source ∈ state.active + networkSent : + forall envelope, envelope ∈ state.network -> + envelope ∈ state.sent + historiesActive : HistoriesActive state + +theorem messageForEffect_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {effect : Effect} + {envelope : Envelope} + (created : + messageForEffect config source sourceState effect = some envelope) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + cases effect with + | sendGossip target => + cases found : recoveredTxID config source with + | none => + simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendVote target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | opening kind => + simp_all [messageForEffect] + | restart chosen => + simp_all [messageForEffect] + | completed => + simp_all [messageForEffect] + | rejected reason => + simp_all [messageForEffect] + +theorem retryMessages_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {envelope : Envelope} + (created : + envelope ∈ retryMessages config source sourceState) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + rw [retryMessages, List.mem_filterMap] at created + rcases created with ⟨effect, _, produced⟩ + exact messageForEffect_source produced + +theorem retryMessages_valid + (config : Config) + (source : Location) + (sourceState : NodeState) + (sourceLocation : sourceState.location = source) : + forall envelope, + envelope ∈ retryMessages config source sourceState -> + envelope.Valid config := by + intro envelope created + rcases retryMessages_source created with + ⟨sourceEq, stateEq⟩ + constructor + · rw [stateEq, sourceEq] + exact sourceLocation + · rw [sourceEq, stateEq] + exact created + +theorem valid_envelope_effect + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) : + exists effect, + effect ∈ + (step config.protocol envelope.sourceState .retry).effects /\ + messageForEffect config envelope.source + envelope.sourceState effect = some envelope := by + rcases valid with ⟨_, created⟩ + rw [retryMessages, List.mem_filterMap] at created + exact created + +theorem valid_gossip_uses_recovered_txid + {config : Config} + {envelope : Envelope} + {txid : TxID} + (valid : envelope.Valid config) + (gossip : envelope.payload = .gossip txid) : + recoveredTxID config envelope.source = some txid := by + rcases valid_envelope_effect valid with + ⟨effect, _, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => + simp [messageForEffect, found] at created + | some recovered => + simp [messageForEffect, found] at created + rw [←created] at gossip + injection gossip with same + subst recovered + rfl + | sendVote target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | opening kind => + simp [messageForEffect] at created + | restart chosen => + simp [messageForEffect] at created + | completed => + simp [messageForEffect] at created + | rejected reason => + simp [messageForEffect] at created + +theorem step_preserves_location + (config : Protocol.Config) + (state : NodeState) + (event : Event) : + (step config state event).state.location = state.location := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +theorem nodeState_location + {state : State} + {node : Location} + {foundState : NodeState} + (locations : + forall entry, entry ∈ state.system.nodes -> + entry.2.location = entry.1) + (found : nodeState state node = some foundState) : + foundState.location = node := by + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have membership : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some findEq + have condition : (entry.1 == node) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq + have keyEq : entry.1 = node := beq_iff_eq.mp condition + rw [←stateEq, locations entry membership, keyEq] + +theorem initial_well_formed + (config : Config) + (active : List Location) + (valid : config.Valid) + (activeNodup : active.Nodup) + (activeConfigured : + forall node, node ∈ active -> + node ∈ config.protocol.expectedLocations) : + WellFormed config (initial config active) := by + constructor + · simp [Global.initial, initialSystem, Function.comp_def] + · simpa [Global.initial, initialSystem, Function.comp_def] using valid.2.1 + · simp [Global.initial, initialSystem, initialNode] + · exact activeNodup + · exact activeConfigured + · simp [Global.initial] + · simp [Global.initial] + · simp [Global.initial] + · constructor <;> simp [Global.initial] + +@[simp] +theorem recordEffects_active + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).active = state.active := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).active = + state.active + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_system + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).system = state.system := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).system = + state.system + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_network + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).network = state.network := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).network = + state.network + rw [ih] + cases effect <;> rfl + +@[simp] +theorem recordEffects_sent + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).sent = state.sent := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).sent = + state.sent + rw [ih] + cases effect <;> rfl + +theorem recordEffect_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffect node nodeState state effect) := by + rcases wellFormed with ⟨openings, restarts, completed⟩ + cases effect <;> + constructor <;> + simp_all [recordEffect] + +theorem recordEffects_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffects node nodeState effects state) := by + induction effects generalizing state with + | nil => exact wellFormed + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + apply ih + · exact recordEffect_preserves_histories_active wellFormed nodeActive + · cases effect <;> simpa [recordEffect] using nodeActive + +theorem mem_of_mem_removeOne + [BEq α] + (value member : α) + (values : List α) : + member ∈ removeOne value values -> + member ∈ values := by + induction values with + | nil => simp [removeOne] + | cons head tail ih => + simp only [removeOne] + split + · exact List.mem_cons_of_mem head + · intro membership + rw [List.mem_cons] at membership ⊢ + exact membership.imp_right ih + +theorem mem_openings_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffect node nodeState state effect).openings := by + cases effect <;> simp_all [recordEffect] + +theorem mem_restarts_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffect node nodeState state effect).restarts := by + cases effect <;> simp_all [recordEffect] + +theorem mem_completed_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffect node nodeState state effect).completed := by + cases effect <;> simp_all [recordEffect] + +theorem mem_openings_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffects node nodeState effects state).openings := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_openings_recordEffect membership) + +theorem mem_restarts_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffects node nodeState effects state).restarts := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_restarts_recordEffect membership) + +theorem mem_completed_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffects node nodeState effects state).completed := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_completed_recordEffect membership) + +theorem replaceNode_keys + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) : + (replaceNode target nextState nodes).map Prod.fst = + nodes.map Prod.fst := by + induction nodes with + | nil => rfl + | cons entry tail ih => + simp only [replaceNode, List.map_cons] + split + · + rename_i condition + have same : entry.1 = target := beq_iff_eq.mp condition + simp only [List.cons.injEq] + constructor + · exact same.symm + · simpa [replaceNode] using ih + · + simp only [List.cons.injEq, true_and] + simpa [replaceNode] using ih + +theorem replaceNode_locations + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (locations : + forall entry, entry ∈ nodes -> + entry.2.location = entry.1) + (nextLocation : nextState.location = target) : + forall entry, entry ∈ replaceNode target nextState nodes -> + entry.2.location = entry.1 := by + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · exact nextLocation + · exact locations previous previousMember + +theorem findNode_replaceNode_ne + (target other : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (different : other ≠ target) : + ((replaceNode target nextState nodes).find? + fun entry => entry.1 == other).map Prod.snd = + (nodes.find? fun entry => entry.1 == other).map Prod.snd := by + let replace : Prod Location NodeState -> Prod Location NodeState := + fun entry => + if entry.1 == target then (target, nextState) else entry + change + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) + (nodes.map replace)) = + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) nodes) + rw [List.find?_map] + have predicate : + ((fun entry : Prod Location NodeState => entry.1 == other) ∘ + replace) = + (fun entry => entry.1 == other) := by + funext entry + by_cases atTarget : entry.1 = target + · simp [replace, atTarget] + · simp [replace, atTarget] + rw [predicate] + cases found : + List.find? (fun entry : Prod Location NodeState => + entry.1 == other) nodes with + | none => simp + | some entry => + have condition : + (entry.1 == other) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == other) found + have entryOther : entry.1 = other := + beq_iff_eq.mp condition + have notTarget : entry.1 ≠ target := by + simpa [entryOther] using different + simp [replace, notTarget] + +theorem systemStep_node_keys_eq + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) : + after.nodes.map Prod.fst = before.nodes.map Prod.fst := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact replaceNode_keys target + (step config node event).state before.nodes + +theorem systemStep_preserves_node_locations + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (locations : + forall entry, entry ∈ before.nodes -> + entry.2.location = entry.1) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.location = entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, stateEq, _⟩ + rw [←stateEq] + apply replaceNode_locations + · exact locations + · calc + (step config node event).state.location = + node.location := step_preserves_location config node event + _ = key := + locations (key, node) (List.mem_of_find?_eq_some found) + _ = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + +theorem systemStep_other_node_eq + {config : Protocol.Config} + {before after : SystemState} + {target other : Location} + {event : Event} + {output : StepOutput} + (different : other ≠ target) + (transition : + systemStep config before target event = some (after, output)) : + (after.nodes.find? fun entry => entry.1 == other).map Prod.snd = + (before.nodes.find? fun entry => entry.1 == other).map Prod.snd := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact findNode_replaceNode_ne target other + (step config node event).state before.nodes different + +theorem next_active_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.active = before.active := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, _, rfl⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, _, _, rfl⟩ + simp + +theorem next_node_keys_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.system.nodes.map Prod.fst = + before.system.nodes.map Prod.fst := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, systemStep, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, systemStep, _, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + +theorem retry_system_eq + {config : Config} + {before after : State} + {source : Location} + (transition : next config before (.retry source) = some after) : + after.system = before.system := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + +theorem deliver_network_eq + {config : Config} + {before after : State} + {envelope : Envelope} + (transition : next config before (.deliver envelope) = some after) : + after.network = removeOne envelope before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + simp + +theorem timeout_network_eq + {config : Config} + {before after : State} + {target : Location} + (transition : next config before (.timeout target) = some after) : + after.network = before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + simp + +theorem deliver_other_node_eq + {config : Config} + {before after : State} + {envelope : Envelope} + {other : Location} + (different : other ≠ envelope.target) + (transition : next config before (.deliver envelope) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +theorem timeout_other_node_eq + {config : Config} + {before after : State} + {target other : Location} + (different : other ≠ target) + (transition : next config before (.timeout target) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +theorem next_sent_extends + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + exists added, after.sent = before.sent ++ added := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact ⟨retryMessages config source sourceState, rfl⟩ + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + +theorem next_openings_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall opening, opening ∈ before.openings -> + opening ∈ after.openings := by + intro opening membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + +theorem next_restarts_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall restart, restart ∈ before.restarts -> + restart ∈ after.restarts := by + intro restart membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + +theorem next_completed_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall completed, completed ∈ before.completed -> + completed ∈ after.completed := by + intro completed membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + +theorem retry_preserves_well_formed + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.retry source) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨sourceActive, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + constructor + · exact wellFormed.nodeKeys + · exact wellFormed.nodeKeysNodup + · exact wellFormed.nodeLocations + · exact wellFormed.activeNodup + · exact wellFormed.activeConfigured + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentValid envelope membership + · exact retryMessages_valid config source sourceState + sourceLocation envelope membership + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentSourceActive envelope membership + · rw [(retryMessages_source membership).1] + exact sourceActive + · intro envelope membership + rw [List.mem_append] at membership ⊢ + rcases membership with membership | membership + · exact Or.inl (wellFormed.networkSent envelope membership) + · exact Or.inr membership + · constructor + · exact wellFormed.historiesActive.openings + · exact wellFormed.historiesActive.restarts + · exact wellFormed.historiesActive.completed + +theorem deliver_preserves_well_formed + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (transition : next config before (.deliver envelope) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending + (mem_of_mem_removeOne envelope pending before.network membership) + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +theorem timeout_preserves_well_formed + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.timeout target) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨targetActive, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending membership + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +theorem next_preserves_well_formed + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (transition : next config before action = some after) : + WellFormed config after := by + cases action with + | retry source => + exact retry_preserves_well_formed wellFormed transition + | deliver envelope => + exact deliver_preserves_well_formed wellFormed transition + | timeout target => + exact timeout_preserves_well_formed wellFormed transition + +theorem reachable_well_formed + {config : Config} + {state : State} + (reachable : Reachable config state) : + WellFormed config state := by + induction reachable with + | initial active valid nodup configured => + exact initial_well_formed config active valid nodup configured + | step reachable transition wellFormed => + exact next_preserves_well_formed wellFormed transition + +theorem reachable_config_valid + {config : Config} + {state : State} + (reachable : Reachable config state) : + config.Valid := by + induction reachable with + | initial active valid nodup configured => exact valid + | step reachable transition valid => exact valid + +end DisasterRecovery.Protocol.Global From 9a81d9895c82cb59ba0e64afcb265c00d5bab028 Mon Sep 17 00:00:00 2001 From: Amaury Chamayou Date: Mon, 7 Sep 2026 19:05:45 +0100 Subject: [PATCH 09/12] Separate Lean review contracts from proof implementations Keep protocol definitions and explicit system properties on the human-review surface. Move proof implementations to checked helper lemmas and use standard Lake build, axiom lint, and import coverage checks. Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- .gitattributes | 5 +- .github/workflows/README.md | 10 +- .github/workflows/lean-disaster-recovery.yml | 5 +- lean/disaster-recovery/AxiomChecks.lean | 21 - lean/disaster-recovery/CanonicalTests.lean | 2 +- lean/disaster-recovery/DisasterRecovery.lean | 14 +- .../DisasterRecovery/Proofs/Committed.lean | 243 ++ .../Proofs/GlobalTemporal.lean | 3002 +++++++++++++++++ .../DisasterRecovery/Proofs/Invariants.lean | 870 +++++ .../DisasterRecovery/Proofs/Quorum.lean | 1389 ++++++++ .../DisasterRecovery/Proofs/Temporal.lean | 197 ++ .../DisasterRecovery/Properties.lean | 209 ++ .../DisasterRecovery/Protocol/Committed.lean | 226 +- .../Protocol/GlobalTemporal.lean | 2992 +--------------- .../DisasterRecovery/Protocol/Invariants.lean | 862 +---- .../DisasterRecovery/Protocol/Quorum.lean | 1380 +------- .../DisasterRecovery/Protocol/Temporal.lean | 190 +- lean/disaster-recovery/README.md | 86 +- lean/disaster-recovery/lake-manifest.json | 12 + lean/disaster-recovery/lakefile.toml | 8 + 20 files changed, 6034 insertions(+), 5689 deletions(-) delete mode 100644 lean/disaster-recovery/AxiomChecks.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Proofs/Committed.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Proofs/Invariants.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Proofs/Temporal.lean create mode 100644 lean/disaster-recovery/DisasterRecovery/Properties.lean diff --git a/.gitattributes b/.gitattributes index 05028087a74..dadda9180ea 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8,4 +8,7 @@ src/crypto/test/cbor_fuzz_corpus/* binary *.h linguist-language=C++ *.cpp linguist-language=C++ -.*canary merge=keeplocal \ No newline at end of file +.*canary merge=keeplocal + +lean/disaster-recovery/DisasterRecovery/Proofs/**/*.lean linguist-generated=true +lean/disaster-recovery/DisasterRecovery.lean text eol=lf \ No newline at end of file diff --git a/.github/workflows/README.md b/.github/workflows/README.md index ef1e552a362..fa2bf87b867 100644 --- a/.github/workflows/README.md +++ b/.github/workflows/README.md @@ -103,9 +103,13 @@ File: `tla-shallow.yml` # Lean Disaster Recovery -Builds the canonical Lean disaster recovery model, checks its proofs without -warnings or project `sorryAx` dependencies, and runs its executable canonical -behavior checks on relevant pull requests. +Builds the canonical Lean disaster recovery model with `lake build --wfail`, +audits its transitive axiom dependencies with `lake lint`, and runs its +executable canonical behavior checks on relevant pull requests. +The build and audit include both the human-reviewed model and system properties +and the proof implementation files marked as generated for review purposes. +The standard `mk_all --check` command ensures that the audit root imports every +library module, so newly added proofs cannot silently escape the checks. File: `lean-disaster-recovery.yml` 3rd party dependencies: None diff --git a/.github/workflows/lean-disaster-recovery.yml b/.github/workflows/lean-disaster-recovery.yml index 7ce96fd4523..31085ba5efa 100644 --- a/.github/workflows/lean-disaster-recovery.yml +++ b/.github/workflows/lean-disaster-recovery.yml @@ -41,6 +41,7 @@ jobs: shell: bash run: | set -euo pipefail - lake build - lake env lean -DwarningAsError=true AxiomChecks.lean + lake exe mk_all --check --lib DisasterRecovery + lake build --wfail + lake lint lake exe canonical-checks diff --git a/lean/disaster-recovery/AxiomChecks.lean b/lean/disaster-recovery/AxiomChecks.lean deleted file mode 100644 index a962639129b..00000000000 --- a/lean/disaster-recovery/AxiomChecks.lean +++ /dev/null @@ -1,21 +0,0 @@ -import DisasterRecovery -import Lean.Elab.Command -import Lean.Util.CollectAxioms - -open Lean Elab Command - -elab "#assert_no_project_sorries" : command => do - let env <- getEnv - let mut offenders : Array Name := #[] - for (name, _) in env.constants.toList do - if name.toString.startsWith "DisasterRecovery" then - let axioms <- liftCoreM <| Lean.collectAxioms name - if axioms.contains (Name.mkSimple "sorryAx") then - offenders := offenders.push name - unless offenders.isEmpty do - throwError "declarations contain sorryAx: {offenders}" - -#assert_no_project_sorries - -def main : IO Unit := - pure () diff --git a/lean/disaster-recovery/CanonicalTests.lean b/lean/disaster-recovery/CanonicalTests.lean index 451d0d6a6f7..426f5a1ea43 100644 --- a/lean/disaster-recovery/CanonicalTests.lean +++ b/lean/disaster-recovery/CanonicalTests.lean @@ -141,5 +141,5 @@ def main : IO UInt32 := do let (twoStates, twoEdges) <- enumerate config "A" IO.println s!"canonical n=1: {oneStates} states, {oneEdges} event edges" IO.println s!"canonical n=2: {twoStates} states, {twoEdges} event edges" - IO.println "all canonical semantic and proof checks passed" + IO.println "all canonical semantic checks passed" pure 0 diff --git a/lean/disaster-recovery/DisasterRecovery.lean b/lean/disaster-recovery/DisasterRecovery.lean index 009747c7166..5c3139abf78 100644 --- a/lean/disaster-recovery/DisasterRecovery.lean +++ b/lean/disaster-recovery/DisasterRecovery.lean @@ -1,7 +1,13 @@ -import DisasterRecovery.Protocol.Model -import DisasterRecovery.Protocol.Temporal +import DisasterRecovery.Proofs.Committed +import DisasterRecovery.Proofs.GlobalTemporal +import DisasterRecovery.Proofs.Invariants +import DisasterRecovery.Proofs.Quorum +import DisasterRecovery.Proofs.Temporal +import DisasterRecovery.Properties +import DisasterRecovery.Protocol.Committed import DisasterRecovery.Protocol.Global +import DisasterRecovery.Protocol.GlobalTemporal import DisasterRecovery.Protocol.Invariants +import DisasterRecovery.Protocol.Model import DisasterRecovery.Protocol.Quorum -import DisasterRecovery.Protocol.Committed -import DisasterRecovery.Protocol.GlobalTemporal +import DisasterRecovery.Protocol.Temporal diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/Committed.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/Committed.lean new file mode 100644 index 00000000000..a4df5646924 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/Committed.lean @@ -0,0 +1,243 @@ +import DisasterRecovery.Protocol.Committed +import DisasterRecovery.Proofs.Quorum +import Mathlib.Tactic + +/-! +Machine-checked proof implementations. Review the system-level statements in +`DisasterRecovery.Properties` and assumptions in `DisasterRecovery.Protocol.Committed`. +-/ + +namespace DisasterRecovery.Protocol + +namespace TxID + +lemma prefix_refl (txid : TxID) : PrefixOf txid txid := by + simp [PrefixOf] + +lemma prefix_trans + {first second third : TxID} + (firstSecond : PrefixOf first second) + (secondThird : PrefixOf second third) : + PrefixOf first third := by + simp [PrefixOf] at firstSecond secondThird ⊢ + omega + +end TxID + +namespace Global + +lemma prefix_of_score_true + (leftName rightName : Location) + (left right : TxID) + (score : + txScoreGreater leftName left rightName right = true) : + TxID.PrefixOf right left := by + simp [txScoreGreater] at score + simp [TxID.PrefixOf] + omega + +lemma prefix_of_score_false + (leftName rightName : Location) + (left right : TxID) + (score : + txScoreGreater leftName left rightName right = false) : + TxID.PrefixOf left right := by + simp [txScoreGreater] at score + simp [TxID.PrefixOf] + omega + +lemma current_prefix_selectMaximum + (current candidate : Prod Location TxID) : + TxID.PrefixOf current.2 + (selectMaximum current candidate).2 := by + unfold selectMaximum + split + · rename_i score + exact prefix_of_score_true + candidate.1 current.1 candidate.2 current.2 score + · exact TxID.prefix_refl current.2 + +lemma candidate_prefix_selectMaximum + (current candidate : Prod Location TxID) : + TxID.PrefixOf candidate.2 + (selectMaximum current candidate).2 := by + unfold selectMaximum + split + · exact TxID.prefix_refl candidate.2 + · rename_i score + exact prefix_of_score_false + candidate.1 current.1 candidate.2 current.2 + (Bool.eq_false_iff.mpr score) + +lemma foldl_selectMaximum_upper_bound + (current member : Prod Location TxID) + (tail : List (Prod Location TxID)) + (membership : member = current \/ member ∈ tail) : + TxID.PrefixOf member.2 + (tail.foldl selectMaximum current).2 := by + induction tail generalizing current member with + | nil => + simp at membership + subst member + exact TxID.prefix_refl current.2 + | cons candidate rest ih => + simp only [List.foldl_cons] + rcases membership with currentMember | tailMember + · subst member + exact TxID.prefix_trans + (current_prefix_selectMaximum current candidate) + (ih (selectMaximum current candidate) + (selectMaximum current candidate) (Or.inl rfl)) + · rw [List.mem_cons] at tailMember + rcases tailMember with candidateMember | restMember + · subst member + exact TxID.prefix_trans + (candidate_prefix_selectMaximum current candidate) + (ih (selectMaximum current candidate) + (selectMaximum current candidate) (Or.inl rfl)) + · exact ih (selectMaximum current candidate) member + (Or.inr restMember) + +lemma maximumGossip_upper_bound + {gossips : List (Prod Location TxID)} + {selected member : Prod Location TxID} + (maximum : maximumGossip gossips = some selected) + (membership : member ∈ gossips) : + TxID.PrefixOf member.2 selected.2 := by + cases gossips with + | nil => simp at membership + | cons head tail => + simp [maximumGossip] at maximum + rw [←maximum] + apply foldl_selectMaximum_upper_bound head member tail + simpa using membership + +lemma foldl_selectMaximum_mem + (current : Prod Location TxID) + (tail : List (Prod Location TxID)) : + tail.foldl selectMaximum current ∈ current :: tail := by + induction tail generalizing current with + | nil => simp + | cons candidate rest ih => + simp only [List.foldl_cons] + have selected : + selectMaximum current candidate = current \/ + selectMaximum current candidate = candidate := by + unfold selectMaximum + split <;> simp + have member := + ih (selectMaximum current candidate) + rw [List.mem_cons] at member + rcases member with currentMember | restMember + · rw [currentMember] + rcases selected with selected | selected + · simp [selected] + · simp [selected] + · simp [restMember] + +lemma maximumGossip_mem + {gossips : List (Prod Location TxID)} + {selected : Prod Location TxID} + (maximum : maximumGossip gossips = some selected) : + selected ∈ gossips := by + cases gossips with + | nil => simp [maximumGossip] at maximum + | cons head tail => + simp [maximumGossip] at maximum + rw [←maximum] + exact foldl_selectMaximum_mem head tail + +lemma recoveredTxID_of_mem + {config : Config} + {location : Location} + {txid : TxID} + (valid : config.Valid) + (membership : (location, txid) ∈ config.recovered) : + recoveredTxID config location = some txid := by + have keysNodup : (config.recovered.map Prod.fst).Nodup := by + rw [valid.2.2] + exact valid.2.1 + unfold recoveredTxID + cases found : + config.recovered.find? fun entry => entry.1 == location with + | none => + rw [List.find?_eq_none] at found + exact False.elim + (found (location, txid) membership (by simp)) + | some entry => + have foundMember : entry ∈ config.recovered := + List.mem_of_find?_eq_some found + have foundLocation : entry.1 = location := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location TxID => + entry.1 == location) found) + have same : + entry = (location, txid) := + eq_of_key_eq keysNodup foundMember membership foundLocation + simp [same] + +lemma full_gossip_selection_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := by + have configValid := reachable_config_valid reachable + have wellFormed := reachable_well_formed reachable + have invariant := reachable_quorum_invariant reachable + rcases full with + ⟨vote, sent, payload, target, complete⟩ + have voteState := + retry_vote_state (wellFormed.sentValid vote sent) payload + rcases invariant.sentVotesSelected vote sent payload with + ⟨selectedTarget, selectedTxID, choice, selected⟩ + have selectedTargetEq : selectedTarget = vote.target := + Option.some.inj (choice.symm.trans voteState.2) + rw [selectedTargetEq, target] at selected + rcases durable with + ⟨durableLocation, durableTxID, durableMember, committedDurable⟩ + have durableGossip : + (durableLocation, durableTxID) ∈ vote.sourceState.gossips := + (complete (durableLocation, durableTxID)).2 durableMember + have durableMaximum := + maximumGossip_upper_bound selected durableGossip + have selectedGossip : + (opener, selectedTxID) ∈ vote.sourceState.gossips := + maximumGossip_mem selected + have selectedRecovered : + (opener, selectedTxID) ∈ config.recovered := + (complete (opener, selectedTxID)).1 selectedGossip + exact + ⟨selectedTxID, + recoveredTxID_of_mem configValid selectedRecovered, + TxID.prefix_trans committedDurable durableMaximum⟩ + +/-- +Quorum opening scopes the result to an actual decision, while the separate +`FullGossipSelection` premise carries the completeness requirement. Quorum +opening alone does not imply complete gossip because voting may follow a +gossip timeout. +-/ +lemma quorum_open_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (_opened : QuorumOpened state opener) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := + full_gossip_selection_preserves_commit reachable full durable + +end Global + +end DisasterRecovery.Protocol diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean new file mode 100644 index 00000000000..79c9db807a0 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean @@ -0,0 +1,3002 @@ +import DisasterRecovery.Protocol.GlobalTemporal +import DisasterRecovery.Proofs.Committed +import DisasterRecovery.Proofs.Temporal +import Mathlib.Tactic + +/-! +Machine-checked proof implementations. Review the system-level statements in +`DisasterRecovery.Properties` and assumptions in `DisasterRecovery.Protocol.GlobalTemporal`. +-/ + +namespace DisasterRecovery.Protocol.Global + +lemma hasPhase_unique + {state : State} + {node : Location} + {first second : Phase} + (firstPhase : HasPhase state node first) + (secondPhase : HasPhase state node second) : + first = second := by + rcases firstPhase with ⟨firstState, firstFound, firstEq⟩ + rcases secondPhase with ⟨secondState, secondFound, secondEq⟩ + rw [firstFound] at secondFound + injection secondFound with stateEq + subst secondState + exact firstEq.symm.trans secondEq + +lemma step_preserves_lane + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (valid : LaneValid state) : + LaneValid (step config state event).state := by + cases event + all_goals try cases_type Validation + all_goals + simp [LaneValid, step, rejected, advance, advanceTimeoutLane, + advanceTimeoutState, validTimeout] at valid ⊢ + all_goals repeat first | split | simp_all | aesop + +lemma step_preserves_advanced_lane + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (advanced : state.timeoutState ≠ .gossiping) : + (step config state event).state.timeoutState ≠ .gossiping := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState] at advanced ⊢ + all_goals repeat first | split | simp_all + +lemma systemStep_preserves_lanes + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (valid : + forall entry, entry ∈ before.nodes -> + LaneValid entry.2) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + LaneValid entry.2 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · apply step_preserves_lane config node event + exact valid (key, node) (List.mem_of_find?_eq_some found) + · exact valid previous previousMember + +lemma initial_lanes_valid + (config : Config) + (active : List Location) : + NodeLanesValid (initial config active) := by + simp [NodeLanesValid, LaneValid, Global.initial, initialSystem, + initialNode] + +lemma next_preserves_lanes + {config : Config} + {before after : State} + {action : Action} + (valid : NodeLanesValid before) + (transition : next config before action = some after) : + NodeLanesValid after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_lanes valid systemStep + entry membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_lanes valid systemStep + entry membership + +lemma reachable_lanes_valid + {config : Config} + {state : State} + (reachable : Reachable config state) : + NodeLanesValid state := by + induction reachable with + | initial active valid nodup configured => + exact initial_lanes_valid config active + | step reachable transition valid => + exact next_preserves_lanes valid transition + +lemma nodeState_eq_of_mem + {state : State} + {node : Location} + {foundState : NodeState} + (keysNodup : (state.system.nodes.map Prod.fst).Nodup) + (membership : (node, foundState) ∈ state.system.nodes) : + Global.nodeState state node = some foundState := by + unfold Global.nodeState + cases found : + state.system.nodes.find? fun entry => entry.1 == node with + | none => + rw [List.find?_eq_none] at found + exact False.elim + (found (node, foundState) membership (by simp)) + | some entry => + have foundMember : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some found + have foundKey : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) found) + have same : entry = (node, foundState) := + eq_of_key_eq keysNodup foundMember membership foundKey + simp [same] + +lemma node_property_of_nodeState + {state : State} + {node : Location} + {foundState : NodeState} + {predicate : NodeState -> Prop} + (property : + forall entry, entry ∈ state.system.nodes -> + predicate entry.2) + (found : Global.nodeState state node = some foundState) : + predicate foundState := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + rw [←stateEq] + exact property entry (List.mem_of_find?_eq_some findEq) + +lemma deliver_target_state + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (transition : next config before (.deliver envelope) = some after) : + exists output, + Global.nodeState after envelope.target = some output.state /\ + systemStep config.protocol before.system envelope.target + (eventFor envelope) = some (after.system, output) := by + have afterWellFormed := + next_preserves_well_formed wellFormed transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] at afterWellFormed ⊢ + refine ⟨output, ?_, ?_⟩ + · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · simpa using systemStep + +lemma timeout_target_state + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.timeout target) = some after) : + exists output, + Global.nodeState after target = some output.state /\ + output.accepted = true /\ + systemStep config.protocol before.system target .timeout = + some (after.system, output) := by + have afterWellFormed := + next_preserves_well_formed wellFormed transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, accepted, stateEq⟩ + rw [←stateEq] at afterWellFormed ⊢ + refine ⟨output, ?_, accepted, ?_⟩ + · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · simpa using systemStep + +lemma systemStep_output_eq + {config : Protocol.Config} + {global : State} + {after : SystemState} + {target : Location} + {event : Event} + {state : NodeState} + {output : StepOutput} + (found : Global.nodeState global target = some state) + (transition : + systemStep config global.system target event = some (after, output)) : + output = step config state event := by + change + (do + let node <- Global.nodeState global target + let result := step config node event + pure ({ + nodes := replaceNode target result.state global.system.nodes + }, result)) = some (after, output) at transition + rw [found] at transition + simp at transition + exact transition.2.symm + +lemma completed_effect_recorded + {node : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (completed : .completed ∈ effects) : + node ∈ (recordEffects node nodeState effects state).completed := by + induction effects generalizing state with + | nil => simp at completed + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + rw [List.mem_cons] at completed + rcases completed with rfl | inTail + · apply mem_completed_recordEffects + simp [recordEffect] + · exact ih inTail + +lemma restart_effect_recorded + {node chosen : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (restart : .restart chosen ∈ effects) : + node ∈ (recordEffects node nodeState effects state).restarts := by + induction effects generalizing state with + | nil => simp at restart + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + rw [List.mem_cons] at restart + rcases restart with rfl | inTail + · apply mem_restarts_recordEffects + simp [recordEffect] + · exact ih inTail + +lemma mem_removeOne_or_eq + [BEq α] + [LawfulBEq α] + {member removed : α} + {values : List α} + (membership : member ∈ values) : + member ∈ removeOne removed values \/ member = removed := by + induction values with + | nil => simp at membership + | cons head tail ih => + rw [List.mem_cons] at membership + rcases membership with rfl | inTail + · by_cases equal : member = removed + · exact Or.inr equal + · exact Or.inl (by simp [removeOne, equal]) + · simp only [removeOne] + split + · exact Or.inl inTail + · rcases ih inTail with still | equal + · exact Or.inl (by simp [still]) + · exact Or.inr equal + +lemma execution_reachable + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) : + forall n, Reachable config (execution.states n) := by + intro n + induction n with + | zero => exact initial + | succ n reachable => + exact Reachable.step reachable (execution.step_succ n) + +lemma execution_active_eq + {config : Config} + (execution : Execution config) : + forall n, (execution.states n).active = (execution.states 0).active := by + intro n + induction n with + | zero => rfl + | succ n activeEq => + exact (next_active_eq (execution.step_succ n)).trans activeEq + +lemma active_at + {config : Config} + (execution : Execution config) + {node : Location} + (active : node ∈ (execution.states 0).active) : + forall n, node ∈ (execution.states n).active := by + intro n + rw [execution_active_eq execution n] + exact active + +lemma recovered_for_configured + {config : Config} + (valid : config.Valid) + {node : Location} + (configured : node ∈ config.protocol.expectedLocations) : + exists txid, recoveredTxID config node = some txid := by + rw [←valid.2.2] at configured + rcases List.mem_map.mp configured with + ⟨entry, membership, keyEq⟩ + rcases entry with ⟨location, txid⟩ + simp at keyEq + subst location + refine ⟨txid, ?_⟩ + apply recoveredTxID_of_mem valid + exact membership + +lemma active_nodeState + {config : Config} + {state : State} + (wellFormed : WellFormed config state) + {node : Location} + (active : node ∈ state.active) : + exists nodeState, + Global.nodeState state node = some nodeState := by + have configured := wellFormed.activeConfigured node active + rw [←wellFormed.nodeKeys] at configured + rcases List.mem_map.mp configured with + ⟨entry, membership, keyEq⟩ + refine ⟨entry.2, ?_⟩ + apply nodeState_eq_of_mem wellFormed.nodeKeysNodup + rcases entry with ⟨location, nodeState⟩ + simp at keyEq + subst location + exact membership + +lemma retryMessages_self_gossip + {config : Config} + {node : Location} + {state : NodeState} + {txid : TxID} + (phase : state.phase = .gossiping) + (configured : node ∈ config.protocol.expectedLocations) + (recovered : recoveredTxID config node = some txid) : + { + source := node + target := node + payload := Payload.gossip txid + sourceState := state + } ∈ retryMessages config node state := by + rw [retryMessages, List.mem_filterMap] + refine ⟨.sendGossip node, ?_, ?_⟩ + · simpa [step, phase] using configured + · simp [messageForEffect, recovered] + +lemma retryMessages_vote + {config : Config} + {node target : Location} + {state : NodeState} + (phase : state.phase = .voting) + (chosen : state.chosen = some target) : + { + source := node + target + payload := Payload.vote + sourceState := state + } ∈ retryMessages config node state := by + rw [retryMessages, List.mem_filterMap] + refine ⟨.sendVote target, ?_, rfl⟩ + simp [step, phase, chosen] + +lemma retry_iamopen_state + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) + (announcement : envelope.payload = .iAmOpen) : + envelope.sourceState.phase = .opening := by + rcases valid_envelope_effect valid with + ⟨effect, member, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] at announcement + contradiction + | sendVote target => + simp [messageForEffect] at created + rw [←created] at announcement + contradiction + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at announcement ⊢ + cases phase : envelope.sourceState.phase + case opening => rfl + case voting => + cases chosen : envelope.sourceState.chosen <;> + simp [step, phase, chosen] at member + all_goals simp [step, phase] at member + | opening kind => simp [messageForEffect] at created + | restart chosen => simp [messageForEffect] at created + | completed => simp [messageForEffect] at created + | rejected reason => simp [messageForEffect] at created + +lemma step_joining_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (joining : (step config state event).state.phase = .joining) : + state.phase = .joining \/ + exists source, acceptedIAmOpenSource event = some source := by + cases event + all_goals try cases_type Validation + all_goals + simp [acceptedIAmOpenSource, step, rejected, advance, + advanceTimeoutLane] at joining ⊢ + all_goals + repeat first | split at joining | split | simp_all | aesop + +lemma step_open_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (opened : (step config state event).state.phase = .open) : + state.phase = .open \/ + .completed ∈ (step config state event).effects := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opened ⊢ + all_goals + repeat first | split at opened | split | simp_all | aesop + +lemma iamopen_delivery_outcome + (config : Protocol.Config) + (state : NodeState) + (source : Location) : + let output := step config state (.receiveIAmOpen source .accepted) + output.state.phase = .opening \/ + output.state.phase = .open \/ + exists chosen, .restart chosen ∈ output.effects := by + cases phase : state.phase <;> + simp [step, phase, rejected, advance, advanceTimeoutLane] + +lemma iamopen_open_predecessor + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (opened : + (step config state (.receiveIAmOpen source .accepted)).state.phase = + .open) : + state.phase = .open := by + cases phase : state.phase <;> + simp [step, phase, rejected, advance, advanceTimeoutLane] at opened + rfl + +lemma eventFor_iamopen_source + {envelope : Envelope} + {source : Location} + (accepted : + acceptedIAmOpenSource (eventFor envelope) = some source) : + envelope.payload = .iAmOpen /\ + envelope.source = source := by + cases payload : envelope.payload <;> + simp_all [eventFor, acceptedIAmOpenSource] + +lemma retry_gossip_enabled + {config : Config} + {state : State} + {node : Location} + (valid : config.Valid) + (wellFormed : WellFormed config state) + (active : node ∈ state.active) + (phase : HasPhase state node .gossiping) : + Enabled config state (.retry node) := by + rcases phase with ⟨nodeState, found, gossiping⟩ + have configured := wellFormed.activeConfigured node active + rcases recovered_for_configured valid configured with + ⟨txid, recovered⟩ + have message := + retryMessages_self_gossip gossiping configured recovered + have messagesNonempty : + retryMessages config node nodeState ≠ [] := by + intro empty + rw [empty] at message + simp at message + refine ⟨{ + state with + network := state.network ++ retryMessages config node nodeState + sent := state.sent ++ retryMessages config node nodeState + }, ?_⟩ + simp [next, active, found, messagesNonempty] + +lemma retry_voting_enabled + {config : Config} + {state : State} + {node target : Location} + {nodeState : NodeState} + (active : node ∈ state.active) + (found : Global.nodeState state node = some nodeState) + (phase : nodeState.phase = .voting) + (chosen : nodeState.chosen = some target) : + Enabled config state (.retry node) := by + have message := retryMessages_vote (config := config) + (node := node) phase chosen + have messagesNonempty : + retryMessages config node nodeState ≠ [] := by + intro empty + rw [empty] at message + simp at message + refine ⟨{ + state with + network := state.network ++ retryMessages config node nodeState + sent := state.sent ++ retryMessages config node nodeState + }, ?_⟩ + simp [next, active, found, messagesNonempty] + +lemma delivery_enabled + {config : Config} + {state : State} + {envelope : Envelope} + (wellFormed : WellFormed config state) + (network : envelope ∈ state.network) + (targetActive : envelope.target ∈ state.active) : + Enabled config state (.deliver envelope) := by + rcases active_nodeState wellFormed targetActive with + ⟨targetState, found⟩ + let output := step config.protocol targetState (eventFor envelope) + let system : SystemState := { + nodes := replaceNode envelope.target output.state state.system.nodes + } + let delivered : State := { + state with + system + network := removeOne envelope state.network + } + have stepResult : + systemStep config.protocol state.system envelope.target + (eventFor envelope) = some (system, output) := by + change + (do + let node <- Global.nodeState state envelope.target + let result := step config.protocol node (eventFor envelope) + pure ({ + nodes := + replaceNode envelope.target result.state state.system.nodes + }, result)) = some (system, output) + rw [found] + rfl + refine + ⟨recordEffects envelope.target output.state output.effects delivered, ?_⟩ + simp [next, network, targetActive, stepResult, output, system, + delivered] + +lemma timeout_enabled_of_accepted + {config : Config} + {state : State} + {node : Location} + {nodeState : NodeState} + (active : node ∈ state.active) + (found : Global.nodeState state node = some nodeState) + (accepted : (step config.protocol nodeState .timeout).accepted = true) : + Enabled config state (.timeout node) := by + let output := step config.protocol nodeState .timeout + let system : SystemState := { + nodes := replaceNode node output.state state.system.nodes + } + have stepResult : + systemStep config.protocol state.system node .timeout = + some (system, output) := by + change + (do + let current <- Global.nodeState state node + let result := step config.protocol current .timeout + pure ({ + nodes := replaceNode node result.state state.system.nodes + }, result)) = some (system, output) + rw [found] + rfl + refine + ⟨recordEffects node output.state output.effects + { state with system }, ?_⟩ + simp [next, active, stepResult, accepted, output, system] + +lemma retry_gossip_enqueued + {config : Config} + {before after : State} + {node : Location} + (valid : config.Valid) + (wellFormed : WellFormed config before) + (phase : HasPhase before node .gossiping) + (transition : next config before (.retry node) = some after) : + exists envelope, + envelope ∈ after.network /\ + envelope.source = node /\ + envelope.target = node /\ + exists txid, envelope.payload = .gossip txid := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨active, sourceState, found, _, stateEq⟩ + rcases phase with ⟨phaseState, foundPhase, gossiping⟩ + have configured := + wellFormed.activeConfigured node active + rcases recovered_for_configured valid configured with + ⟨txid, recovered⟩ + rw [found] at foundPhase + injection foundPhase with stateEq' + subst phaseState + let envelope : Envelope := { + source := node + target := node + payload := .gossip txid + sourceState + } + have message : envelope ∈ retryMessages config node sourceState := + retryMessages_self_gossip gossiping configured recovered + rw [←stateEq] + exact + ⟨envelope, List.mem_append_right _ message, rfl, rfl, txid, rfl⟩ + +lemma retry_vote_enqueued + {config : Config} + {before after : State} + {node target : Location} + {nodeState : NodeState} + (found : Global.nodeState before node = some nodeState) + (phase : nodeState.phase = .voting) + (chosen : nodeState.chosen = some target) + (transition : next config before (.retry node) = some after) : + exists envelope, + envelope ∈ after.network /\ + envelope.source = node /\ + envelope.target = target /\ + envelope.payload = .vote := by + have message := retryMessages_vote (config := config) + (node := node) phase chosen + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, actualState, actualFound, _, stateEq⟩ + rw [found] at actualFound + injection actualFound with actualEq + subst actualState + let envelope : Envelope := { + source := node + target + payload := .vote + sourceState := nodeState + } + rw [←stateEq] + exact + ⟨envelope, List.mem_append_right _ message, rfl, rfl, rfl⟩ + +lemma insertGossip_nonempty + (source : Location) + (txid : TxID) + (gossips : List (Prod Location TxID)) : + insertGossip source txid gossips ≠ [] := by + unfold insertGossip + split + · rename_i present + intro empty + subst gossips + simp at present + · intro empty + have lengths := + (List.mergeSort_perm ((source, txid) :: gossips) + (fun left right => left.1 <= right.1)).length_eq + rw [empty] at lengths + simp at lengths + +lemma maximumGossip_some + {gossips : List (Prod Location TxID)} + (nonempty : gossips ≠ []) : + exists selected, maximumGossip gossips = some selected := by + cases gossips with + | nil => contradiction + | cons head tail => + exact ⟨tail.foldl selectMaximum head, rfl⟩ + +lemma gossip_receive_progress + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (txid : TxID) + (valid : LaneValid state) + (phase : state.phase = .gossiping) : + let output := + step config state (.receiveGossip source txid .accepted) + output.state.phase ≠ .gossiping \/ + output.state.gossips ≠ [] := by + have chosen := valid.2.2.2 phase + have nonempty := insertGossip_nonempty source txid state.gossips + obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty + simp [step, phase, chosen, rejected, advance, advanceTimeoutLane, + validTimeout] + repeat first | split | simp_all + +lemma gossip_timeout_progress + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .gossiping) + (accepted : (step config state .timeout).accepted = true) : + (step config state .timeout).state.phase = .voting := by + have lane := valid.1 phase + simp [step, phase, lane, rejected, advance, advanceTimeoutLane, + validTimeout] at accepted ⊢ + repeat first | split at accepted | split | simp_all + +lemma gossip_timeout_enabled_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .gossiping) + (nonempty : state.gossips ≠ []) : + (step config state .timeout).accepted = true := by + have lane := valid.1 phase + obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty + simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + maximum] + +lemma gossip_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (lanes : NodeLanesValid state) + (phase : HasPhase state node .gossiping) + (gossip : HasGossip state node) : + Enabled config state (.timeout node) := by + rcases phase with ⟨phaseState, foundPhase, gossiping⟩ + rcases gossip with ⟨gossipState, foundGossip, nonempty⟩ + rw [foundPhase] at foundGossip + injection foundGossip with stateEq + subst gossipState + have lane := node_property_of_nodeState lanes foundPhase + apply timeout_enabled_of_accepted active foundPhase + exact gossip_timeout_enabled_local config.protocol phaseState lane + gossiping nonempty + +lemma opening_timeout_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .opening) : + let output := step config state .timeout + (output.effects = [.completed] /\ output.state.phase = .open) \/ + (output.state.phase = .opening /\ + openingDistance output.state.timeoutState < + openingDistance state.timeoutState) := by + rcases valid.2.2.1 phase with lane | lane | lane + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, + advanceTimeoutState, openingDistance] + +lemma opening_step_distance_le + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (valid : LaneValid state) + (phase : state.phase = .opening) + (after : (step config state event).state.phase = .opening) : + openingDistance (step config state event).state.timeoutState <= + openingDistance state.timeoutState := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => + rcases opening_timeout_local config state valid phase with + done | progress + · rw [done.2] at after + contradiction + · exact Nat.le_of_lt progress.2 + | retry => simp [step] + +lemma opening_step_or_completed + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (phase : state.phase = .opening) : + (step config state event).state.phase = .opening \/ + ((step config state event).state.phase = .open /\ + .completed ∈ (step config state event).effects) := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + split <;> simp_all + | retry => simp [step, phase] + +lemma opening_non_timeout + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (phase : state.phase = .opening) + (notTimeout : event ≠ .timeout) : + (step config state event).state.phase = .opening /\ + (step config state event).state.timeoutState = + state.timeoutState := by + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + | receiveVote source validation => + cases validation <;> + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> simp [step, phase, rejected] + | timeout => contradiction + | retry => exact ⟨phase, rfl⟩ + +lemma opening_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (phase : HasPhase state node .opening) : + Enabled config state (.timeout node) := by + rcases phase with ⟨nodeState, found, opening⟩ + apply timeout_enabled_of_accepted active found + simp [step, opening, advance, rejected] + repeat first | split | simp_all + +lemma timeout_opening_step + {config : Config} + {before after : State} + {node : Location} + {beforeState : NodeState} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (foundBefore : + Global.nodeState before node = some beforeState) + (opening : beforeState.phase = .opening) + (transition : next config before (.timeout node) = some after) : + CompletedOpen after node \/ + (exists nextState : NodeState, + Global.nodeState after node = some nextState /\ + nextState.phase = .opening /\ + openingDistance nextState.timeoutState < + openingDistance beforeState.timeoutState) := by + have lane : LaneValid beforeState := by + apply node_property_of_nodeState (predicate := LaneValid) + · exact lanes + · exact foundBefore + have timeoutResult : + ((step config.protocol beforeState .timeout).effects = + [.completed] /\ + (step config.protocol beforeState .timeout).state.phase = .open) \/ + ((step config.protocol beforeState .timeout).state.phase = + .opening /\ + openingDistance + (step config.protocol beforeState .timeout).state.timeoutState < + openingDistance beforeState.timeoutState) := + opening_timeout_local config.protocol beforeState lane opening + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + rw [←outputEq] at timeoutResult + rw [←stateEq] + rcases timeoutResult with completed | progress + · exact Or.inl (by + rcases completed with ⟨effects, _⟩ + rw [effects] + simp [CompletedOpen, recordEffects, recordEffect]) + · exact Or.inr + ⟨output.state, + (by + apply nodeState_eq_of_mem + · rw [recordEffects_system, + systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · rw [recordEffects_system] + exact systemStep_output_mem systemStep), + progress.1, + by simpa using progress.2⟩ + +lemma next_opening_progress + {config : Config} + {before after : State} + {node : Location} + {beforeState : NodeState} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (foundBefore : + Global.nodeState before node = some beforeState) + (opening : beforeState.phase = .opening) + (transition : next config before action = some after) : + CompletedOpen after node \/ + (exists afterState : NodeState, + Global.nodeState after node = some afterState /\ + afterState.phase = .opening /\ + openingDistance afterState.timeoutState <= + openingDistance beforeState.timeoutState) := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact Or.inr + ⟨beforeState, foundBefore, opening, Nat.le_refl _⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have preserved := + opening_non_timeout config.protocol beforeState + (eventFor envelope) opening + (by + cases payloadEq : envelope.payload <;> + simp [eventFor, payloadEq]) + rw [←outputEq] at preserved + exact Or.inr + ⟨output.state, foundAfter, preserved.1, + by rw [preserved.2]⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact Or.inr + ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_opening_step wellFormed lanes foundBefore + opening transition with + completed | ⟨nextState, foundAfter, nextOpening, distance⟩ + · exact Or.inl completed + · exact Or.inr + ⟨nextState, foundAfter, nextOpening, + Nat.le_of_lt distance⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact Or.inr + ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ + +lemma insertVote_nonempty + (source : Location) + (votes : List Location) : + insertVote source votes ≠ [] := by + unfold insertVote + split + · rename_i present + intro empty + subst votes + simp at present + · intro empty + have lengths := + (List.mergeSort_perm (source :: votes) + (fun left right => left <= right)).length_eq + rw [empty] at lengths + simp at lengths + +lemma step_preserves_nonempty_votes + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (nonempty : state.votes ≠ []) : + (step config state event).state.votes ≠ [] := by + rcases step_votes_shape config state event with + unchanged | ⟨source, _, changed⟩ + · rw [unchanged] + exact nonempty + · rw [changed] + exact insertVote_nonempty source state.votes + +lemma next_preserves_hasVote + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (vote : HasVote before node) + (transition : next config before action = some after) : + HasVote after node := by + rcases vote with ⟨beforeState, foundBefore, nonempty⟩ + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact ⟨beforeState, foundBefore, nonempty⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState (eventFor envelope) nonempty⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], nonempty⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState .timeout nonempty⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], nonempty⟩ + +lemma hasVote_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (vote : HasVote (execution.states start) node) : + HasVote (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact vote + | succ finish order vote => + exact next_preserves_hasVote + (reachable_well_formed + (execution_reachable execution initial finish)) + vote (execution.step_succ finish) + +lemma next_preserves_advanced_lane + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (advanced : LaneAdvanced before node) + (transition : next config before action = some after) : + LaneAdvanced after node := by + rcases advanced with ⟨beforeState, foundBefore, lane⟩ + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact ⟨beforeState, foundBefore, lane⟩ + | deliver envelope => + by_cases target : node = envelope.target + · subst node + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_advanced_lane + config.protocol beforeState (eventFor envelope) lane⟩ + · have unchanged := deliver_other_node_eq target transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], lane⟩ + | timeout target => + by_cases same : node = target + · subst node + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact step_preserves_advanced_lane + config.protocol beforeState .timeout lane⟩ + · have unchanged := timeout_other_node_eq same transition + rw [foundBefore] at unchanged + exact ⟨beforeState, by simp [unchanged], lane⟩ + +lemma advanced_lane_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (advanced : LaneAdvanced (execution.states start) node) : + LaneAdvanced (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact advanced + | succ finish order advanced => + exact next_preserves_advanced_lane + (reachable_well_formed + (execution_reachable execution initial finish)) + advanced (execution.step_succ finish) + +lemma opening_progress_between + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + {startState : NodeState} + (order : start <= finish) + (foundStart : + Global.nodeState (execution.states start) node = some startState) + (openingStart : startState.phase = .opening) + (notCompleted : + Not (CompletedOpen (execution.states finish) node)) : + exists finishState : NodeState, + Global.nodeState (execution.states finish) node = some finishState /\ + finishState.phase = .opening /\ + openingDistance finishState.timeoutState <= + openingDistance startState.timeoutState := by + induction finish, order using Nat.le_induction with + | base => + exact + ⟨startState, foundStart, openingStart, Nat.le_refl _⟩ + | succ finish order ih => + have notCompletedBefore : + Not (CompletedOpen (execution.states finish) node) := by + intro completed + exact notCompleted + (next_completed_monotonic + (execution.step_succ finish) node completed) + rcases ih notCompletedBefore with + ⟨beforeState, foundBefore, openingBefore, distanceBefore⟩ + rcases next_opening_progress + (reachable_well_formed + (execution_reachable execution initial finish)) + (reachable_lanes_valid + (execution_reachable execution initial finish)) + foundBefore openingBefore (execution.step_succ finish) with + completed | + ⟨afterState, foundAfter, openingAfter, distanceAfter⟩ + · contradiction + · exact + ⟨afterState, foundAfter, openingAfter, + Nat.le_trans distanceAfter distanceBefore⟩ + +lemma deliver_gossip_progress + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (payload : exists txid, envelope.payload = .gossip txid) + (phase : HasPhase before envelope.target .gossiping) + (transition : next config before (.deliver envelope) = some after) : + Not (HasPhase after envelope.target .gossiping) \/ + HasGossip after envelope.target := by + rcases phase with ⟨beforeState, foundBefore, gossiping⟩ + rcases payload with ⟨txid, payload⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have lane := + node_property_of_nodeState lanes foundBefore + simp [eventFor, payload] at outputEq + have progress := + gossip_receive_progress config.protocol beforeState + envelope.source txid lane gossiping + rw [←outputEq] at progress + rcases progress with left | right + · exact Or.inl (by + intro stillGossiping + rcases stillGossiping with ⟨state, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst state + exact left phase) + · exact Or.inr ⟨output.state, foundAfter, right⟩ + +lemma timeout_gossip_progress + {config : Config} + {before after : State} + {node : Location} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (phase : HasPhase before node .gossiping) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .voting := by + rcases phase with ⟨beforeState, foundBefore, gossiping⟩ + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, accepted, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + have lane := + node_property_of_nodeState lanes foundBefore + have voting := + gossip_timeout_progress config.protocol beforeState lane + gossiping (by simpa [outputEq] using accepted) + exact + ⟨output.state, foundAfter, by simpa [outputEq] using voting⟩ + +lemma vote_receive_progress + (config : Protocol.Config) + (state : NodeState) + (source : Location) + (phase : state.phase = .voting) : + let output := step config state (.receiveVote source .accepted) + output.state.phase ≠ .voting \/ output.state.votes ≠ [] := by + have nonempty := insertVote_nonempty source state.votes + simp [step, phase, rejected, advance, validTimeout, + advanceTimeoutLane] + repeat first | split | simp_all + +lemma voting_timeout_local + (config : Protocol.Config) + (state : NodeState) + (valid : LaneValid state) + (phase : state.phase = .voting) + (nonempty : state.votes ≠ []) : + let output := step config state .timeout + output.state.phase = .opening \/ + (output.state.phase = .voting /\ + output.state.timeoutState = .voting) := by + rcases valid.2.1 phase with lane | lane + · simp [step, phase, lane, rejected, advance, validTimeout, + advanceTimeoutLane, advanceTimeoutState] + repeat first | split | simp_all + · simp [step, phase, lane, nonempty, rejected, advance, validTimeout, + advanceTimeoutLane, advanceTimeoutState] + +lemma aligned_voting_timeout_opens + (config : Protocol.Config) + (state : NodeState) + (phase : state.phase = .voting) + (lane : state.timeoutState = .voting) + (nonempty : state.votes ≠ []) : + (step config state .timeout).state.phase = .opening := by + simp [step, phase, lane, nonempty, rejected, advance, validTimeout, + advanceTimeoutLane] + +lemma deliver_vote_progress + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (payload : envelope.payload = .vote) + (phase : HasPhase before envelope.target .voting) + (transition : next config before (.deliver envelope) = some after) : + Not (HasPhase after envelope.target .voting) \/ + HasVote after envelope.target := by + rcases phase with ⟨beforeState, foundBefore, voting⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + have outputEq := + systemStep_output_eq foundBefore systemStep + simp [eventFor, payload] at outputEq + have progress := + vote_receive_progress config.protocol beforeState + envelope.source voting + rw [←outputEq] at progress + rcases progress with left | right + · exact Or.inl (by + intro stillVoting + rcases stillVoting with ⟨state, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst state + exact left phase) + · exact Or.inr ⟨output.state, foundAfter, right⟩ + +lemma deliver_iamopen_resolves + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (openCompleted : OpenCompleted before) + (payload : envelope.payload = .iAmOpen) + (transition : next config before (.deliver envelope) = some after) : + Terminal after envelope.target \/ + HasPhase after envelope.target .opening := by + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + simp [eventFor, payload] at outputEq + have outcome := + iamopen_delivery_outcome config.protocol beforeState envelope.source + rw [←outputEq] at outcome + rw [←stateEq] + rcases outcome with opening | opened | ⟨chosen, restarted⟩ + · exact Or.inr + ⟨output.state, + by + apply nodeState_eq_of_mem + · rw [recordEffects_system, + systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · rw [recordEffects_system] + exact systemStep_output_mem systemStep, + opening⟩ + · have beforeOpen := + iamopen_open_predecessor config.protocol beforeState + envelope.source (by simpa [outputEq] using opened) + have completedBefore : CompletedOpen before envelope.target := by + rw [Global.nodeState, Option.map_eq_some_iff] at foundBefore + rcases foundBefore with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = envelope.target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == envelope.target) findEq) + rw [←keyEq] + apply openCompleted entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using beforeOpen + exact Or.inl (Or.inr + (mem_completed_recordEffects completedBefore)) + · exact Or.inl (Or.inl + (restart_effect_recorded restarted)) + +lemma voting_timeout_enabled + {config : Config} + {state : State} + {node : Location} + (active : node ∈ state.active) + (phase : HasPhase state node .voting) : + Enabled config state (.timeout node) := by + rcases phase with ⟨nodeState, found, voting⟩ + apply timeout_enabled_of_accepted active found + simp [step, voting, advance, rejected] + repeat first | split | simp_all + +lemma timeout_voting_step + {config : Config} + {before after : State} + {node : Location} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (phase : HasPhase before node .voting) + (vote : HasVote before node) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .opening \/ + (exists nextState : NodeState, + Global.nodeState after node = some nextState /\ + nextState.phase = .voting /\ + nextState.timeoutState = .voting /\ + nextState.votes ≠ []) := by + rcases phase with ⟨beforeState, foundBefore, voting⟩ + rcases vote with ⟨voteState, foundVote, nonempty⟩ + rw [foundBefore] at foundVote + injection foundVote with stateEq + subst voteState + have lane : LaneValid beforeState := by + apply node_property_of_nodeState (predicate := LaneValid) + · exact lanes + · exact foundBefore + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := systemStep_output_eq foundBefore systemStep + have progress := + voting_timeout_local config.protocol beforeState lane voting nonempty + rw [←outputEq] at progress + rcases progress with opening | waiting + · exact Or.inl ⟨output.state, foundAfter, opening⟩ + · exact Or.inr + ⟨output.state, foundAfter, waiting.1, waiting.2, + by + rw [outputEq] + exact step_preserves_nonempty_votes + config.protocol beforeState .timeout nonempty⟩ + +lemma aligned_timeout_voting_opens + {config : Config} + {before after : State} + {node : Location} + {nodeState : NodeState} + (wellFormed : WellFormed config before) + (found : Global.nodeState before node = some nodeState) + (phase : nodeState.phase = .voting) + (lane : nodeState.timeoutState = .voting) + (nonempty : nodeState.votes ≠ []) + (transition : next config before (.timeout node) = some after) : + HasPhase after node .opening := by + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + have outputEq := systemStep_output_eq found systemStep + exact + ⟨output.state, foundAfter, + by + rw [outputEq] + exact aligned_voting_timeout_opens config.protocol nodeState + phase lane nonempty⟩ + +lemma fair_gossip_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + {node : Location} + (active : node ∈ (execution.states start).active) + (phase : HasPhase (execution.states start) node .gossiping) : + EventuallyFrom start (fun n => + Not (HasPhase (execution.states n) node .gossiping)) := by + have reachable (n : Nat) := + execution_reachable execution initial n + have configValid := reachable_config_valid (reachable start) + have retryEnabled := + retry_gossip_enabled configValid + (reachable_well_formed (reachable start)) active phase + rcases fair.retry start node .gossiping active phase + (Or.inl rfl) retryEnabled with + ⟨retryAt, startRetry, leftGossip | retryAction⟩ + · exact ⟨retryAt, startRetry, leftGossip⟩ + · by_cases retryPhase : + HasPhase (execution.states retryAt) node .gossiping + · have retryStep : + next config (execution.states retryAt) (.retry node) = + some (execution.states (retryAt + 1)) := by + simpa [retryAction] using execution.step_succ retryAt + rcases retry_gossip_enqueued configValid + (reachable_well_formed (reachable retryAt)) + retryPhase retryStep with + ⟨envelope, pending, sourceEq, targetEq, txid, payload⟩ + rcases fair.delivery (retryAt + 1) envelope pending with + ⟨deliverAt, retryDeliver, deliverAction⟩ + by_cases deliverPhase : + HasPhase (execution.states deliverAt) node .gossiping + · have deliverStep : + next config (execution.states deliverAt) + (.deliver envelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + have delivered := + deliver_gossip_progress + (reachable_well_formed (reachable deliverAt)) + (reachable_lanes_valid (reachable deliverAt)) + ⟨txid, payload⟩ + (by simpa [targetEq] using deliverPhase) + deliverStep + rcases delivered with leftAfter | hasGossip + · exact + ⟨deliverAt + 1, by omega, by simpa [targetEq] using leftAfter⟩ + · by_cases afterPhase : + HasPhase (execution.states (deliverAt + 1)) node .gossiping + · have timeoutEnabled := + gossip_timeout_enabled + (config := config) + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + (reachable_lanes_valid (reachable (deliverAt + 1))) + afterPhase + (by simpa [targetEq] using hasGossip) + rcases fair.timeout (deliverAt + 1) node .gossiping + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + afterPhase (Or.inl rfl) timeoutEnabled with + ⟨timeoutAt, deliverTimeout, leftBeforeTimeout | timeoutAction⟩ + · exact ⟨timeoutAt, by omega, leftBeforeTimeout⟩ + · by_cases timeoutPhase : + HasPhase (execution.states timeoutAt) node .gossiping + · have timeoutStep : + next config (execution.states timeoutAt) + (.timeout node) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using + execution.step_succ timeoutAt + have voting := + timeout_gossip_progress + (reachable_well_formed (reachable timeoutAt)) + (reachable_lanes_valid (reachable timeoutAt)) + timeoutPhase timeoutStep + refine ⟨timeoutAt + 1, by omega, ?_⟩ + intro impossible + have phases := hasPhase_unique voting impossible + contradiction + · exact ⟨timeoutAt, by omega, timeoutPhase⟩ + · exact ⟨deliverAt + 1, by omega, afterPhase⟩ + · exact ⟨deliverAt, by omega, deliverPhase⟩ + · exact ⟨retryAt, startRetry, retryPhase⟩ + +lemma next_gossiping_predecessor + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (wellFormed : WellFormed config before) + (transition : next config before action = some after) + (afterGossip : HasPhase after node .gossiping) : + HasPhase before node .gossiping := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] at afterGossip + exact afterGossip + | deliver envelope => + by_cases target : node = envelope.target + · subst node + have details := transition + simp [next, Option.bind_eq_some_iff] at details + have targetActive := details.2.1 + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + rcases deliver_target_state wellFormed transition with + ⟨output, foundAfter, systemStep⟩ + rcases afterGossip with ⟨afterState, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst afterState + have outputEq := + systemStep_output_eq foundBefore systemStep + have beforePhase : beforeState.phase = .gossiping := by + by_contra notGossip + have notAfter := + step_preserves_non_gossiping config.protocol beforeState + (eventFor envelope) notGossip + rw [←outputEq] at notAfter + exact notAfter phase + exact ⟨beforeState, foundBefore, beforePhase⟩ + · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ + have unchanged := + deliver_other_node_eq target transition + rw [foundAfter] at unchanged + cases foundBefore : + Global.nodeState before node with + | none => simp [foundBefore] at unchanged + | some beforeState => + rw [foundBefore] at unchanged + injection unchanged with stateEq + subst beforeState + exact ⟨afterState, foundBefore, phase⟩ + | timeout target => + by_cases same : node = target + · subst node + have details := transition + simp [next, Option.bind_eq_some_iff] at details + have targetActive := details.1 + rcases active_nodeState wellFormed targetActive with + ⟨beforeState, foundBefore⟩ + rcases timeout_target_state wellFormed transition with + ⟨output, foundAfter, _, systemStep⟩ + rcases afterGossip with ⟨afterState, found, phase⟩ + rw [foundAfter] at found + injection found with stateEq + subst afterState + have outputEq := + systemStep_output_eq foundBefore systemStep + have beforePhase : beforeState.phase = .gossiping := by + by_contra notGossip + have notAfter := + step_preserves_non_gossiping config.protocol beforeState + .timeout notGossip + rw [←outputEq] at notAfter + exact notAfter phase + exact ⟨beforeState, foundBefore, beforePhase⟩ + · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ + have unchanged := + timeout_other_node_eq same transition + rw [foundAfter] at unchanged + cases foundBefore : + Global.nodeState before node with + | none => simp [foundBefore] at unchanged + | some beforeState => + rw [foundBefore] at unchanged + injection unchanged with stateEq + subst beforeState + exact ⟨afterState, foundBefore, phase⟩ + +lemma not_gossiping_mono + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (notGossip : + Not (HasPhase (execution.states start) node .gossiping)) : + Not (HasPhase (execution.states finish) node .gossiping) := by + induction finish, order using Nat.le_induction with + | base => exact notGossip + | succ finish order notGossip => + intro gossip + exact notGossip + (next_gossiping_predecessor + (reachable_well_formed + (execution_reachable execution initial finish)) + (execution.step_succ finish) gossip) + +lemma eventually_list + {predicate : Nat -> Location -> Prop} + {start : Nat} + (nodes : List Location) + (eventual : + forall node, node ∈ nodes -> + EventuallyFrom start (fun n => predicate n node)) + (monotonic : + forall node first second, + first <= second -> + predicate first node -> + predicate second node) : + EventuallyFrom start (fun n => + forall node, node ∈ nodes -> predicate n node) := by + revert eventual + induction nodes with + | nil => + intro eventual + exact ⟨start, Nat.le_refl start, by simp⟩ + | cons head tail ih => + intro eventual + rcases eventual head (by simp) with + ⟨headAt, startHead, headHolds⟩ + rcases ih + (fun node membership => eventual node (by simp [membership])) with + ⟨tailAt, startTail, tailHolds⟩ + refine + ⟨max headAt tailAt, by omega, ?_⟩ + intro node membership + rw [List.mem_cons] at membership + rcases membership with rfl | inTail + · exact monotonic _ headAt (max headAt tailAt) + (Nat.le_max_left _ _) headHolds + · exact monotonic node tailAt (max headAt tailAt) + (Nat.le_max_right _ _) (tailHolds node inTail) + +lemma fair_all_leave_gossip + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (start : Nat) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + Not (HasPhase (execution.states n) node .gossiping)) := by + apply eventually_list (execution.states start).active + · intro node active + by_cases phase : + HasPhase (execution.states start) node .gossiping + · exact fair_gossip_progress execution initial fair active phase + · exact ⟨start, Nat.le_refl start, phase⟩ + · intro node first second order notGossip + exact not_gossiping_mono execution initial order notGossip + +lemma terminal_mono_step + {config : Config} + {before after : State} + {action : Action} + {node : Location} + (transition : next config before action = some after) + (terminal : Terminal before node) : + Terminal after node := by + rcases terminal with restarted | completed + · exact Or.inl (next_restarts_monotonic transition node restarted) + · exact Or.inr (next_completed_monotonic transition node completed) + +lemma terminal_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (terminal : Terminal (execution.states start) node) : + Terminal (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact terminal + | succ finish order terminal => + exact terminal_mono_step (execution.step_succ finish) terminal + +lemma completed_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (completed : CompletedOpen (execution.states start) node) : + CompletedOpen (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact completed + | succ finish order completed => + exact next_completed_monotonic + (execution.step_succ finish) node completed + +lemma quorumOpened_mono + {config : Config} + (execution : Execution config) + {start finish : Nat} + {node : Location} + (order : start <= finish) + (opened : QuorumOpened (execution.states start) node) : + QuorumOpened (execution.states finish) node := by + induction finish, order using Nat.le_induction with + | base => exact opened + | succ finish order opened => + rcases opened with + ⟨opening, membership, openingNode, kind⟩ + exact + ⟨opening, + next_openings_monotonic + (execution.step_succ finish) opening membership, + openingNode, + kind⟩ + +lemma fair_opening_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + {node : Location} + (active : node ∈ (execution.states start).active) + (phase : HasPhase (execution.states start) node .opening) : + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node) := by + rcases phase with ⟨startState, foundStart, openingStart⟩ + have auxiliary : + forall distance start state, + openingDistance state.timeoutState = distance -> + node ∈ (execution.states start).active -> + Global.nodeState (execution.states start) node = some state -> + state.phase = .opening -> + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node) := by + intro distance + induction distance using Nat.strong_induction_on with + | h distance ih => + intro start state distanceEq active found opening + have enabled := + opening_timeout_enabled (config := config) + active ⟨state, found, opening⟩ + rcases fair.openingTimeout start node active + ⟨state, found, opening⟩ enabled with + ⟨timeoutAt, startTimeout, + completed | ⟨stillOpening, timeoutAction⟩⟩ + · exact ⟨timeoutAt, startTimeout, completed⟩ + · by_cases completedBefore : + CompletedOpen (execution.states timeoutAt) node + · exact ⟨timeoutAt, startTimeout, completedBefore⟩ + · rcases opening_progress_between execution initial startTimeout + found opening completedBefore with + ⟨timeoutState, foundTimeout, openingTimeout, + distanceTimeout⟩ + have timeoutStep : + next config (execution.states timeoutAt) + (.timeout node) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using execution.step_succ timeoutAt + rcases timeout_opening_step + (reachable_well_formed + (execution_reachable execution initial timeoutAt)) + (reachable_lanes_valid + (execution_reachable execution initial timeoutAt)) + foundTimeout openingTimeout timeoutStep with + completedAfter | + ⟨nextState, foundNext, openingNext, distanceNext⟩ + · exact ⟨timeoutAt + 1, by omega, completedAfter⟩ + · have nextLess : openingDistance nextState.timeoutState < + distance := by + rw [←distanceEq] + exact Nat.lt_of_lt_of_le distanceNext distanceTimeout + rcases ih (openingDistance nextState.timeoutState) + nextLess (timeoutAt + 1) nextState rfl + (by + rw [execution_active_eq execution (timeoutAt + 1)] + rw [execution_active_eq execution start] at active + exact active) + foundNext openingNext with + ⟨completedAt, nextCompleted, completed⟩ + exact ⟨completedAt, by omega, completed⟩ + exact auxiliary (openingDistance startState.timeoutState) + start startState rfl active foundStart openingStart + +lemma initial_announcements_live + (config : Config) + (active : List Location) : + AnnouncementsLive (initial config active) := by + simp [AnnouncementsLive, Global.initial] + +lemma next_preserves_announcements_live + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (live : AnnouncementsLive before) + (transition : next config before action = some after) : + AnnouncementsLive after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · exact live envelope old payload + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have opening := retry_iamopen_state valid payload + have identity := retryMessages_source added + rw [identity.2] at opening + exact Or.inl + ⟨sourceState, + by simpa [identity.1] using found, + opening⟩ + | deliver delivered => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases live envelope membership payload with + opening | completed + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr completed + · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ + · exact Or.inr + (next_completed_monotonic transition envelope.source completed) + | timeout target => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases live envelope membership payload with + opening | completed + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr completed + · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ + · exact Or.inr + (next_completed_monotonic transition envelope.source completed) + +lemma reachable_announcements_live + {config : Config} + {state : State} + (reachable : Reachable config state) : + AnnouncementsLive state := by + induction reachable with + | initial active valid nodup configured => + exact initial_announcements_live config active + | step reachable transition live => + exact next_preserves_announcements_live + (reachable_well_formed reachable) + (reachable_lanes_valid reachable) + live transition + +lemma initial_announcements_resolved + (config : Config) + (active : List Location) : + AnnouncementsResolved (initial config active) := by + simp [AnnouncementsResolved, Global.initial] + +lemma next_preserves_announcements_resolved + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (lanes : NodeLanesValid before) + (openCompleted : OpenCompleted before) + (resolved : AnnouncementsResolved before) + (transition : next config before action = some after) : + AnnouncementsResolved after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · rcases resolved envelope old payload with + pending | terminal | opening + · exact Or.inl (List.mem_append_left _ pending) + · exact Or.inr (Or.inl terminal) + · exact Or.inr (Or.inr opening) + · exact Or.inl (List.mem_append_right _ added) + | deliver delivered => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases resolved envelope membership payload with + pending | terminal | opening + · rcases mem_removeOne_or_eq pending with remains | equal + · exact Or.inl (by + rw [←stateEq, recordEffects_network] + exact remains) + · subst envelope + rcases deliver_iamopen_resolves wellFormed openCompleted payload + transition with + terminal | opening + · exact Or.inr (Or.inl terminal) + · exact Or.inr (Or.inr opening) + · exact Or.inr (Or.inl + (terminal_mono_step transition terminal)) + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr (Or.inl (Or.inr completed)) + · exact Or.inr (Or.inr + ⟨afterState, foundAfter, phaseAfter⟩) + | timeout target => + intro envelope membership payload + have details := transition + simp [next, Option.bind_eq_some_iff] at details + rcases details with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq, recordEffects_sent] at membership + rcases resolved envelope membership payload with + pending | terminal | opening + · exact Or.inl (by + rw [←stateEq, recordEffects_network] + exact pending) + · exact Or.inr (Or.inl + (terminal_mono_step transition terminal)) + · rcases opening with ⟨sourceState, found, phase⟩ + rcases next_opening_progress wellFormed lanes found phase + transition with + completed | ⟨afterState, foundAfter, phaseAfter, _⟩ + · exact Or.inr (Or.inl (Or.inr completed)) + · exact Or.inr (Or.inr + ⟨afterState, foundAfter, phaseAfter⟩) + +lemma systemStep_preserves_joining_announcements + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (valid : JoiningAnnouncements beforeState) + (carry : + forall destination, + SentAnnouncementTo beforeState destination -> + SentAnnouncementTo afterState destination) + (introduced : + (exists source, acceptedIAmOpenSource event = some source) -> + SentAnnouncementTo afterState target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .joining -> + SentAnnouncementTo afterState entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership joining + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + rcases step_joining_origin config node event + (by simpa [atTarget, outputEq] using joining) with + old | received + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + rw [←keyEq] + apply carry + apply valid (key, node) + · rw [beforeSystem] + exact List.mem_of_find?_eq_some found + · exact old + · exact introduced received + · rename_i notTarget + apply carry + apply valid previous + · rw [beforeSystem] + exact previousMember + · simpa [notTarget] using joining + +lemma initial_joining_announcements + (config : Config) + (active : List Location) : + JoiningAnnouncements (initial config active) := by + simp [JoiningAnnouncements, Global.initial, initialSystem, initialNode] + +lemma next_preserves_joining_announcements + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (valid : JoiningAnnouncements before) + (transition : next config before action = some after) : + JoiningAnnouncements after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rcases valid entry membership joining with + ⟨envelope, sent, target, payload⟩ + exact + ⟨envelope, List.mem_append_left _ sent, target, payload⟩ + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨inNetwork, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall destination, + SentAnnouncementTo before destination -> + SentAnnouncementTo afterState destination := by + intro destination announcement + rcases announcement with + ⟨sentEnvelope, sent, target, payload⟩ + exact + ⟨sentEnvelope, by simpa [afterState] using sent, + target, payload⟩ + have introduced : + (exists source, + acceptedIAmOpenSource (eventFor envelope) = some source) -> + SentAnnouncementTo afterState envelope.target := by + rintro ⟨source, accepted⟩ + rcases eventFor_iamopen_source accepted with + ⟨payload, _⟩ + exact + ⟨envelope, + by + simp [afterState] + exact wellFormed.networkSent envelope inNetwork, + rfl, payload⟩ + exact systemStep_preserves_joining_announcements + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep + entry membership joining + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership joining + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall destination, + SentAnnouncementTo before destination -> + SentAnnouncementTo afterState destination := by + intro destination announcement + rcases announcement with + ⟨sentEnvelope, sent, target, payload⟩ + exact + ⟨sentEnvelope, by simpa [afterState] using sent, + target, payload⟩ + have introduced : + (exists source, + acceptedIAmOpenSource Event.timeout = some source) -> + SentAnnouncementTo afterState target := by + rintro ⟨source, accepted⟩ + simp [acceptedIAmOpenSource] at accepted + exact systemStep_preserves_joining_announcements + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep + entry membership joining + +lemma reachable_joining_announcements + {config : Config} + {state : State} + (reachable : Reachable config state) : + JoiningAnnouncements state := by + induction reachable with + | initial active valid nodup configured => + exact initial_joining_announcements config active + | step reachable transition valid => + exact next_preserves_joining_announcements + (reachable_well_formed reachable) valid transition + +lemma systemStep_preserves_open_completed + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (valid : OpenCompleted beforeState) + (carry : + forall node, + CompletedOpen beforeState node -> + CompletedOpen afterState node) + (introduced : + .completed ∈ output.effects -> + CompletedOpen afterState target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .open -> + CompletedOpen afterState entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership opened + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + rcases step_open_origin config node event + (by simpa [atTarget, outputEq] using opened) with + old | completed + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + rw [←keyEq] + apply carry + apply valid (key, node) + · rw [beforeSystem] + exact List.mem_of_find?_eq_some found + · exact old + · rw [outputEq] at completed + exact introduced completed + · rename_i notTarget + apply carry + apply valid previous + · rw [beforeSystem] + exact previousMember + · simpa [notTarget] using opened + +lemma initial_open_completed + (config : Config) + (active : List Location) : + OpenCompleted (initial config active) := by + simp [OpenCompleted, Global.initial, initialSystem, initialNode] + +lemma next_preserves_open_completed + {config : Config} + {before after : State} + {action : Action} + (valid : OpenCompleted before) + (transition : next config before action = some after) : + OpenCompleted after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership opened + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall node, + CompletedOpen before node -> + CompletedOpen afterState node := by + intro node completed + apply mem_completed_recordEffects + exact completed + have introduced : + .completed ∈ output.effects -> + CompletedOpen afterState envelope.target := by + intro completed + exact completed_effect_recorded completed + exact systemStep_preserves_open_completed + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep entry membership opened + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership opened + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall node, + CompletedOpen before node -> + CompletedOpen afterState node := by + intro node completed + apply mem_completed_recordEffects + exact completed + have introduced : + .completed ∈ output.effects -> + CompletedOpen afterState target := by + intro completed + exact completed_effect_recorded completed + exact systemStep_preserves_open_completed + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl valid carry introduced systemStep entry membership opened + +lemma reachable_open_completed + {config : Config} + {state : State} + (reachable : Reachable config state) : + OpenCompleted state := by + induction reachable with + | initial active valid nodup configured => + exact initial_open_completed config active + | step reachable transition valid => + exact next_preserves_open_completed valid transition + +lemma reachable_announcements_resolved + {config : Config} + {state : State} + (reachable : Reachable config state) : + AnnouncementsResolved state := by + induction reachable with + | initial active valid nodup configured => + exact initial_announcements_resolved config active + | step reachable transition resolved => + exact next_preserves_announcements_resolved + (reachable_well_formed reachable) + (reachable_lanes_valid reachable) + (reachable_open_completed reachable) + resolved transition + +lemma open_node_completed + {state : State} + {node : Location} + {nodeState : NodeState} + (valid : OpenCompleted state) + (found : Global.nodeState state node = some nodeState) + (opened : nodeState.phase = .open) : + CompletedOpen state node := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply valid entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using opened + +lemma joining_node_announcement + {state : State} + {node : Location} + {nodeState : NodeState} + (valid : JoiningAnnouncements state) + (found : Global.nodeState state node = some nodeState) + (joining : nodeState.phase = .joining) : + SentAnnouncementTo state node := by + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply valid entry (List.mem_of_find?_eq_some findEq) + simpa [stateEq] using joining + +lemma openerWitness_of_later_phase + {config : Config} + {state : State} + {node : Location} + (reachable : Reachable config state) + (active : node ∈ state.active) + (notGossip : Not (HasPhase state node .gossiping)) + (notVoting : Not (HasPhase state node .voting)) : + OpenerWitness state := by + rcases active_nodeState (reachable_well_formed reachable) active with + ⟨nodeState, found⟩ + cases phase : nodeState.phase with + | gossiping => + exact False.elim + (notGossip ⟨nodeState, found, phase⟩) + | voting => + exact False.elim + (notVoting ⟨nodeState, found, phase⟩) + | opening => + exact ⟨node, Or.inl ⟨nodeState, found, phase⟩⟩ + | joining => + rcases joining_node_announcement + (reachable_joining_announcements reachable) + found phase with + ⟨envelope, sent, target, payload⟩ + rcases reachable_announcements_live reachable + envelope sent payload with + opening | completed + · exact ⟨envelope.source, Or.inl opening⟩ + · exact ⟨envelope.source, Or.inr completed⟩ + | «open» => + exact + ⟨node, Or.inr + (open_node_completed + (reachable_open_completed reachable) found phase)⟩ + +lemma openerWitness_after_leave_voting + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + {start later : Nat} + {node : Location} + (order : start <= later) + (allPastGossip : + forall activeNode, + activeNode ∈ (execution.states start).active -> + Not (HasPhase (execution.states start) + activeNode .gossiping)) + (active : node ∈ (execution.states later).active) + (notVoting : + Not (HasPhase (execution.states later) node .voting)) : + OpenerWitness (execution.states later) := by + have activeStart : node ∈ (execution.states start).active := by + rw [execution_active_eq execution later] at active + rw [execution_active_eq execution start] + exact active + have notGossip := + not_gossiping_mono execution initial order + (allPastGossip node activeStart) + exact openerWitness_of_later_phase + (execution_reachable execution initial later) + active notGossip notVoting + +lemma systemStep_preserves_advanced_active + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {active : List Location} + (valid : + forall entry, entry ∈ before.nodes -> + entry.2.phase ≠ .gossiping -> + entry.1 ∈ active) + (targetActive : target ∈ active) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase ≠ .gossiping -> + entry.1 ∈ active := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership advanced + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · exact targetActive + · rename_i notTarget + exact valid previous previousMember + (by simpa [notTarget] using advanced) + +lemma initial_advanced_active + (config : Config) + (active : List Location) : + AdvancedNodesActive (initial config active) := by + simp [AdvancedNodesActive, Global.initial, initialSystem, initialNode] + +lemma next_preserves_advanced_active + {config : Config} + {before after : State} + {action : Action} + (valid : AdvancedNodesActive before) + (transition : next config before action = some after) : + AdvancedNodesActive after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership advanced + rw [recordEffects_system] at membership + simpa using + systemStep_preserves_advanced_active + valid targetActive systemStep entry membership advanced + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨targetActive, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership advanced + rw [recordEffects_system] at membership + simpa using + systemStep_preserves_advanced_active + valid targetActive systemStep entry membership advanced + +lemma reachable_advanced_active + {config : Config} + {state : State} + (reachable : Reachable config state) : + AdvancedNodesActive state := by + induction reachable with + | initial active valid nodup configured => + exact initial_advanced_active config active + | step reachable transition valid => + exact next_preserves_advanced_active valid transition + +lemma hasPhase_active + {config : Config} + {state : State} + {node : Location} + {phase : Phase} + (reachable : Reachable config state) + (hasPhase : HasPhase state node phase) + (advancedPhase : phase ≠ .gossiping) : + node ∈ state.active := by + rcases hasPhase with ⟨nodeState, found, phaseEq⟩ + rw [Global.nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have keyEq : entry.1 = node := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq) + rw [←keyEq] + apply reachable_advanced_active reachable entry + (List.mem_of_find?_eq_some findEq) + rw [stateEq, phaseEq] + exact advancedPhase + +lemma fair_opener_witness + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + (activeNonempty : (execution.states start).active ≠ []) + (allPastGossip : + forall node, node ∈ (execution.states start).active -> + Not (HasPhase (execution.states start) node .gossiping)) : + EventuallyFrom start (fun n => + OpenerWitness (execution.states n)) := by + obtain ⟨voter, voterActive⟩ := + List.exists_mem_of_ne_nil _ activeNonempty + by_cases voting : + HasPhase (execution.states start) voter .voting + · rcases voting with ⟨voterState, foundVoter, voterVoting⟩ + have selectionProperty := + node_property_of_nodeState + (predicate := fun state => + state.phase = .voting -> NodeVotingSelection state) + (reachable_quorum_invariant + (execution_reachable execution initial start)).votingSelections + foundVoter + rcases selectionProperty voterVoting with + ⟨target, txid, chosen, maximum⟩ + have retryEnabled := + retry_voting_enabled (config := config) + voterActive foundVoter voterVoting chosen + rcases fair.retry start voter .voting voterActive + ⟨voterState, foundVoter, voterVoting⟩ + (Or.inr (Or.inl rfl)) retryEnabled with + ⟨retryAt, startRetry, leftVoting | retryAction⟩ + · exact + ⟨retryAt, startRetry, + openerWitness_after_leave_voting execution initial + startRetry allPastGossip + (by + rw [execution_active_eq execution retryAt] + rw [execution_active_eq execution start] at voterActive + exact voterActive) + leftVoting⟩ + · by_cases retryVoting : + HasPhase (execution.states retryAt) voter .voting + · rcases retryVoting with + ⟨retryState, foundRetry, votingRetry⟩ + have retrySelectionProperty := + node_property_of_nodeState + (predicate := fun state => + state.phase = .voting -> NodeVotingSelection state) + (reachable_quorum_invariant + (execution_reachable execution initial retryAt)).votingSelections + foundRetry + rcases retrySelectionProperty votingRetry with + ⟨retryTarget, retryTxID, retryChosen, retryMaximum⟩ + have retryStep : + next config (execution.states retryAt) (.retry voter) = + some (execution.states (retryAt + 1)) := by + simpa [retryAction] using execution.step_succ retryAt + rcases retry_vote_enqueued foundRetry votingRetry retryChosen + retryStep with + ⟨voteEnvelope, pending, voteSource, voteTarget, votePayload⟩ + rcases fair.delivery (retryAt + 1) voteEnvelope pending with + ⟨deliverAt, retryDeliver, deliverAction⟩ + have deliverStep : + next config (execution.states deliverAt) + (.deliver voteEnvelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + have deliverDetails := deliverStep + simp [next, Option.bind_eq_some_iff] at deliverDetails + have targetActive : voteEnvelope.target ∈ + (execution.states deliverAt).active := + deliverDetails.2.1 + by_cases targetVoting : + HasPhase (execution.states deliverAt) + voteEnvelope.target .voting + · rcases deliver_vote_progress + (reachable_well_formed + (execution_reachable execution initial deliverAt)) + votePayload targetVoting deliverStep with + leftAfter | hasVote + · have activeAfter : voteEnvelope.target ∈ + (execution.states (deliverAt + 1)).active := by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] at targetActive + exact targetActive + exact + ⟨deliverAt + 1, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip activeAfter leftAfter⟩ + · by_cases votingAfter : + HasPhase (execution.states (deliverAt + 1)) + voteEnvelope.target .voting + · have activeAfter : voteEnvelope.target ∈ + (execution.states (deliverAt + 1)).active := by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] at targetActive + exact targetActive + have timeoutEnabled := + voting_timeout_enabled (config := config) + activeAfter votingAfter + rcases fair.timeout (deliverAt + 1) + voteEnvelope.target .voting activeAfter votingAfter + (Or.inr (Or.inl rfl)) timeoutEnabled with + ⟨timeoutAt, deliverTimeout, + leftBeforeTimeout | timeoutAction⟩ + · exact + ⟨timeoutAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution timeoutAt] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter) + leftBeforeTimeout⟩ + · by_cases votingAtTimeout : + HasPhase (execution.states timeoutAt) + voteEnvelope.target .voting + · have voteAtTimeout := + hasVote_mono execution initial deliverTimeout hasVote + have timeoutStep : + next config (execution.states timeoutAt) + (.timeout voteEnvelope.target) = + some (execution.states (timeoutAt + 1)) := by + simpa [timeoutAction] using + execution.step_succ timeoutAt + rcases timeout_voting_step + (reachable_well_formed + (execution_reachable execution initial timeoutAt)) + (reachable_lanes_valid + (execution_reachable execution initial timeoutAt)) + votingAtTimeout voteAtTimeout timeoutStep with + opened | + ⟨waitingState, foundWaiting, waitingPhase, + waitingLane, waitingVotes⟩ + · exact + ⟨timeoutAt + 1, by omega, + ⟨voteEnvelope.target, Or.inl opened⟩⟩ + · have activeWaiting : voteEnvelope.target ∈ + (execution.states (timeoutAt + 1)).active := by + rw [execution_active_eq execution (timeoutAt + 1)] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter + have secondEnabled := + voting_timeout_enabled (config := config) + activeWaiting + ⟨waitingState, foundWaiting, waitingPhase⟩ + rcases fair.timeout (timeoutAt + 1) + voteEnvelope.target .voting activeWaiting + ⟨waitingState, foundWaiting, waitingPhase⟩ + (Or.inr (Or.inl rfl)) secondEnabled with + ⟨secondAt, firstSecond, + leftBeforeSecond | secondAction⟩ + · exact + ⟨secondAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution secondAt] + rw [execution_active_eq execution + (timeoutAt + 1)] at activeWaiting + exact activeWaiting) + leftBeforeSecond⟩ + · by_cases votingAtSecond : + HasPhase (execution.states secondAt) + voteEnvelope.target .voting + · rcases votingAtSecond with + ⟨secondState, foundSecond, secondPhase⟩ + have votesSecond := + hasVote_mono execution initial firstSecond + ⟨waitingState, foundWaiting, waitingVotes⟩ + rcases votesSecond with + ⟨voteState, foundVotes, secondVotes⟩ + rw [foundSecond] at foundVotes + injection foundVotes with voteStateEq + subst voteState + have advancedSecond := + advanced_lane_mono execution initial firstSecond + ⟨waitingState, foundWaiting, by simp [waitingLane]⟩ + rcases advancedSecond with + ⟨laneState, foundLane, advanced⟩ + rw [foundSecond] at foundLane + injection foundLane with laneStateEq + subst laneState + have laneValid : LaneValid secondState := by + apply node_property_of_nodeState + (predicate := LaneValid) + · exact reachable_lanes_valid + (execution_reachable execution initial secondAt) + · exact foundSecond + have secondLane : secondState.timeoutState = + .voting := by + rcases laneValid.2.1 secondPhase with + gossipLane | votingLane + · contradiction + · exact votingLane + have secondStep : + next config (execution.states secondAt) + (.timeout voteEnvelope.target) = + some (execution.states (secondAt + 1)) := by + simpa [secondAction] using + execution.step_succ secondAt + have opened := + aligned_timeout_voting_opens + (reachable_well_formed + (execution_reachable execution initial secondAt)) + foundSecond secondPhase secondLane secondVotes + secondStep + exact + ⟨secondAt + 1, by omega, + ⟨voteEnvelope.target, Or.inl opened⟩⟩ + · exact + ⟨secondAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution secondAt] + rw [execution_active_eq execution + (timeoutAt + 1)] at activeWaiting + exact activeWaiting) + votingAtSecond⟩ + · exact + ⟨timeoutAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution timeoutAt] + rw [execution_active_eq execution + (deliverAt + 1)] at activeAfter + exact activeAfter) + votingAtTimeout⟩ + · exact + ⟨deliverAt + 1, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip + (by + rw [execution_active_eq execution (deliverAt + 1)] + rw [execution_active_eq execution deliverAt] + at targetActive + exact targetActive) + votingAfter⟩ + · exact + ⟨deliverAt, by omega, + openerWitness_after_leave_voting execution initial + (by omega) allPastGossip targetActive targetVoting⟩ + · exact + ⟨retryAt, startRetry, + openerWitness_after_leave_voting execution initial + startRetry allPastGossip + (by + rw [execution_active_eq execution retryAt] + rw [execution_active_eq execution start] at voterActive + exact voterActive) + retryVoting⟩ + · exact + ⟨start, Nat.le_refl start, + openerWitness_after_leave_voting execution initial + (Nat.le_refl start) allPastGossip voterActive voting⟩ + +lemma openerWitness_eventually_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + (witness : OpenerWitness (execution.states start)) : + EventuallyFrom start (fun n => + exists node, CompletedOpen (execution.states n) node) := by + rcases witness with ⟨node, opening | completed⟩ + · have active := + hasPhase_active (execution_reachable execution initial start) + opening (by simp) + rcases fair_opening_completes execution initial fair active opening with + ⟨completedAt, order, completed⟩ + exact ⟨completedAt, order, node, completed⟩ + · exact ⟨start, Nat.le_refl start, node, completed⟩ + +lemma fair_some_opener_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) := by + rcases fair_all_leave_gossip execution initial fair 0 with + ⟨pastGossipAt, _, allPastGossip⟩ + have nonemptyAt : + (execution.states pastGossipAt).active ≠ [] := by + rw [execution_active_eq execution pastGossipAt] + exact activeNonempty + have allPastAt : + forall node, node ∈ (execution.states pastGossipAt).active -> + Not (HasPhase (execution.states pastGossipAt) + node .gossiping) := by + intro node active + rw [execution_active_eq execution pastGossipAt] at active + exact allPastGossip node active + rcases fair_opener_witness execution initial fair nonemptyAt + allPastAt with + ⟨witnessAt, pastWitness, witness⟩ + rcases openerWitness_eventually_completes execution initial fair + witness with + ⟨completedAt, witnessCompleted, completed⟩ + exact ⟨completedAt, by omega, completed⟩ + +lemma fair_target_terminal_after_completion + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener target : Location} + (completed : CompletedOpen (execution.states start) opener) + (active : target ∈ (execution.states start).active) : + EventuallyFrom start (fun n => + Terminal (execution.states n) target) := by + by_cases same : target = opener + · subst target + exact ⟨start, Nat.le_refl start, Or.inr completed⟩ + · rcases broadcast start opener completed target active same with + ⟨envelope, sent, sourceEq, targetEq, payload⟩ + rcases reachable_announcements_resolved + (execution_reachable execution initial start) + envelope sent payload with + pending | terminal | opening + · rcases fair.delivery start envelope pending with + ⟨deliverAt, startDelivery, deliverAction⟩ + have deliverStep : + next config (execution.states deliverAt) (.deliver envelope) = + some (execution.states (deliverAt + 1)) := by + simpa [deliverAction] using execution.step_succ deliverAt + rcases deliver_iamopen_resolves + (reachable_well_formed + (execution_reachable execution initial deliverAt)) + (reachable_open_completed + (execution_reachable execution initial deliverAt)) + payload deliverStep with + terminal | targetOpening + · exact + ⟨deliverAt + 1, by omega, by simpa [targetEq] using terminal⟩ + · have openingActive := + hasPhase_active + (execution_reachable execution initial (deliverAt + 1)) + targetOpening (by simp) + rcases fair_opening_completes execution initial fair + openingActive targetOpening with + ⟨completedAt, deliveryCompleted, targetCompleted⟩ + exact + ⟨completedAt, by omega, + by simpa [targetEq] using (Or.inr targetCompleted)⟩ + · exact + ⟨start, Nat.le_refl start, by simpa [targetEq] using terminal⟩ + · have openingActive := + hasPhase_active + (execution_reachable execution initial start) + opening (by simp) + rcases fair_opening_completes execution initial fair + openingActive opening with + ⟨completedAt, startCompleted, targetCompleted⟩ + exact + ⟨completedAt, startCompleted, + by simpa [targetEq] using (Or.inr targetCompleted)⟩ + +lemma fair_all_terminal_after_completion + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (completed : CompletedOpen (execution.states start) opener) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + Terminal (execution.states n) node) := by + apply eventually_list (execution.states start).active + · intro node active + exact fair_target_terminal_after_completion + execution initial fair broadcast completed active + · intro node first second order terminal + exact terminal_mono execution order terminal + +lemma global_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) /\ + EventuallyFrom 0 (fun n => + forall node, node ∈ (execution.states 0).active -> + Terminal (execution.states n) node) := by + have completed := + fair_some_opener_completes execution initial fair activeNonempty + constructor + · exact completed + · rcases completed with + ⟨completedAt, _, opener, openerCompleted⟩ + rcases fair_all_terminal_after_completion execution initial fair + broadcast openerCompleted with + ⟨terminalAt, completedTerminal, allTerminal⟩ + refine ⟨terminalAt, by omega, ?_⟩ + intro node active + apply allTerminal node + rw [execution_active_eq execution completedAt] + exact active + +lemma single_completion_path_joins_others + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (completed : CompletedOpen (execution.states start) opener) + (onlyOpener : OnlyOpenerCompletesFrom execution start opener) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := by + apply eventually_list (execution.states start).active + · intro node active + by_cases same : node = opener + · exact ⟨start, Nat.le_refl start, Or.inl same⟩ + · rcases fair_target_terminal_after_completion + execution initial fair broadcast completed active with + ⟨terminalAt, startTerminal, terminal⟩ + rcases terminal with restarted | targetCompleted + · exact ⟨terminalAt, startTerminal, Or.inr restarted⟩ + · exact False.elim + (same + (onlyOpener terminalAt node startTerminal targetCompleted)) + · intro node first second order joined + rcases joined with same | restarted + · exact Or.inl same + · exact Or.inr + (by + induction second, order using Nat.le_induction with + | base => exact restarted + | succ second order restarted => + exact next_restarts_monotonic + (execution.step_succ second) node restarted) + +lemma quorum_path_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (opened : QuorumOpened (execution.states start) opener) + (completed : CompletedOpen (execution.states start) opener) + (quorumOnly : QuorumOnlyCompletions execution) : + QuorumOpened (execution.states start) opener /\ + CompletedOpen (execution.states start) opener /\ + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := by + have onlyOpener : + OnlyOpenerCompletesFrom execution start opener := by + intro n node startN nodeCompleted + exact quorum_opener_unique + (execution_reachable execution initial n) + (quorumOnly n node nodeCompleted) + (quorumOpened_mono execution startN opened) + exact + ⟨opened, completed, + single_completion_path_joins_others + execution initial fair broadcast completed onlyOpener⟩ + +end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/Invariants.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/Invariants.lean new file mode 100644 index 00000000000..9be993296dc --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/Invariants.lean @@ -0,0 +1,870 @@ +import DisasterRecovery.Protocol.Invariants +import Mathlib.Tactic + +/-! +Machine-checked proof implementations. Review the system-level statements in +`DisasterRecovery.Properties` and definitions in `DisasterRecovery.Protocol.Invariants`. +-/ + +namespace DisasterRecovery.Protocol.Global + +lemma messageForEffect_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {effect : Effect} + {envelope : Envelope} + (created : + messageForEffect config source sourceState effect = some envelope) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + cases effect with + | sendGossip target => + cases found : recoveredTxID config source with + | none => + simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendVote target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] + exact ⟨rfl, rfl⟩ + | opening kind => + simp_all [messageForEffect] + | restart chosen => + simp_all [messageForEffect] + | completed => + simp_all [messageForEffect] + | rejected reason => + simp_all [messageForEffect] + +lemma retryMessages_source + {config : Config} + {source : Location} + {sourceState : NodeState} + {envelope : Envelope} + (created : + envelope ∈ retryMessages config source sourceState) : + envelope.source = source /\ + envelope.sourceState = sourceState := by + rw [retryMessages, List.mem_filterMap] at created + rcases created with ⟨effect, _, produced⟩ + exact messageForEffect_source produced + +lemma retryMessages_valid + (config : Config) + (source : Location) + (sourceState : NodeState) + (sourceLocation : sourceState.location = source) : + forall envelope, + envelope ∈ retryMessages config source sourceState -> + envelope.Valid config := by + intro envelope created + rcases retryMessages_source created with + ⟨sourceEq, stateEq⟩ + constructor + · rw [stateEq, sourceEq] + exact sourceLocation + · rw [sourceEq, stateEq] + exact created + +lemma valid_envelope_effect + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) : + exists effect, + effect ∈ + (step config.protocol envelope.sourceState .retry).effects /\ + messageForEffect config envelope.source + envelope.sourceState effect = some envelope := by + rcases valid with ⟨_, created⟩ + rw [retryMessages, List.mem_filterMap] at created + exact created + +lemma valid_gossip_uses_recovered_txid + {config : Config} + {envelope : Envelope} + {txid : TxID} + (valid : envelope.Valid config) + (gossip : envelope.payload = .gossip txid) : + recoveredTxID config envelope.source = some txid := by + rcases valid_envelope_effect valid with + ⟨effect, _, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => + simp [messageForEffect, found] at created + | some recovered => + simp [messageForEffect, found] at created + rw [←created] at gossip + injection gossip with same + subst recovered + rfl + | sendVote target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at gossip + contradiction + | opening kind => + simp [messageForEffect] at created + | restart chosen => + simp [messageForEffect] at created + | completed => + simp [messageForEffect] at created + | rejected reason => + simp [messageForEffect] at created + +lemma step_preserves_location + (config : Protocol.Config) + (state : NodeState) + (event : Event) : + (step config state event).state.location = state.location := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +lemma nodeState_location + {state : State} + {node : Location} + {foundState : NodeState} + (locations : + forall entry, entry ∈ state.system.nodes -> + entry.2.location = entry.1) + (found : nodeState state node = some foundState) : + foundState.location = node := by + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have membership : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some findEq + have condition : (entry.1 == node) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == node) findEq + have keyEq : entry.1 = node := beq_iff_eq.mp condition + rw [←stateEq, locations entry membership, keyEq] + +lemma initial_well_formed + (config : Config) + (active : List Location) + (valid : config.Valid) + (activeNodup : active.Nodup) + (activeConfigured : + forall node, node ∈ active -> + node ∈ config.protocol.expectedLocations) : + WellFormed config (initial config active) := by + constructor + · simp [Global.initial, initialSystem, Function.comp_def] + · simpa [Global.initial, initialSystem, Function.comp_def] using valid.2.1 + · simp [Global.initial, initialSystem, initialNode] + · exact activeNodup + · exact activeConfigured + · simp [Global.initial] + · simp [Global.initial] + · simp [Global.initial] + · constructor <;> simp [Global.initial] + +@[simp] +lemma recordEffects_active + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).active = state.active := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).active = + state.active + rw [ih] + cases effect <;> rfl + +@[simp] +lemma recordEffects_system + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).system = state.system := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).system = + state.system + rw [ih] + cases effect <;> rfl + +@[simp] +lemma recordEffects_network + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).network = state.network := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).network = + state.network + rw [ih] + cases effect <;> rfl + +@[simp] +lemma recordEffects_sent + (node : Location) + (nodeState : NodeState) + (effects : List Effect) + (state : State) : + (recordEffects node nodeState effects state).sent = state.sent := by + induction effects generalizing state with + | nil => rfl + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + change + (recordEffects node nodeState tail + (recordEffect node nodeState state effect)).sent = + state.sent + rw [ih] + cases effect <;> rfl + +lemma recordEffect_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffect node nodeState state effect) := by + rcases wellFormed with ⟨openings, restarts, completed⟩ + cases effect <;> + constructor <;> + simp_all [recordEffect] + +lemma recordEffects_preserves_histories_active + {node : Location} + {nodeState : NodeState} + {effects : List Effect} + {state : State} + (wellFormed : HistoriesActive state) + (nodeActive : node ∈ state.active) : + HistoriesActive (recordEffects node nodeState effects state) := by + induction effects generalizing state with + | nil => exact wellFormed + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + apply ih + · exact recordEffect_preserves_histories_active wellFormed nodeActive + · cases effect <;> simpa [recordEffect] using nodeActive + +lemma mem_of_mem_removeOne + [BEq α] + (value member : α) + (values : List α) : + member ∈ removeOne value values -> + member ∈ values := by + induction values with + | nil => simp [removeOne] + | cons head tail ih => + simp only [removeOne] + split + · exact List.mem_cons_of_mem head + · intro membership + rw [List.mem_cons] at membership ⊢ + exact membership.imp_right ih + +lemma mem_openings_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffect node nodeState state effect).openings := by + cases effect <;> simp_all [recordEffect] + +lemma mem_restarts_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffect node nodeState state effect).restarts := by + cases effect <;> simp_all [recordEffect] + +lemma mem_completed_recordEffect + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffect node nodeState state effect).completed := by + cases effect <;> simp_all [recordEffect] + +lemma mem_openings_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {opening : Opening} + (membership : opening ∈ state.openings) : + opening ∈ (recordEffects node nodeState effects state).openings := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_openings_recordEffect membership) + +lemma mem_restarts_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {restart : Location} + (membership : restart ∈ state.restarts) : + restart ∈ (recordEffects node nodeState effects state).restarts := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_restarts_recordEffect membership) + +lemma mem_completed_recordEffects + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + {completed : Location} + (membership : completed ∈ state.completed) : + completed ∈ (recordEffects node nodeState effects state).completed := by + induction effects generalizing state with + | nil => exact membership + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + exact ih (mem_completed_recordEffect membership) + +lemma replaceNode_keys + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) : + (replaceNode target nextState nodes).map Prod.fst = + nodes.map Prod.fst := by + induction nodes with + | nil => rfl + | cons entry tail ih => + simp only [replaceNode, List.map_cons] + split + · + rename_i condition + have same : entry.1 = target := beq_iff_eq.mp condition + simp only [List.cons.injEq] + constructor + · exact same.symm + · simpa [replaceNode] using ih + · + simp only [List.cons.injEq, true_and] + simpa [replaceNode] using ih + +lemma replaceNode_locations + (target : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (locations : + forall entry, entry ∈ nodes -> + entry.2.location = entry.1) + (nextLocation : nextState.location = target) : + forall entry, entry ∈ replaceNode target nextState nodes -> + entry.2.location = entry.1 := by + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · exact nextLocation + · exact locations previous previousMember + +lemma findNode_replaceNode_ne + (target other : Location) + (nextState : NodeState) + (nodes : List (Prod Location NodeState)) + (different : other ≠ target) : + ((replaceNode target nextState nodes).find? + fun entry => entry.1 == other).map Prod.snd = + (nodes.find? fun entry => entry.1 == other).map Prod.snd := by + let replace : Prod Location NodeState -> Prod Location NodeState := + fun entry => + if entry.1 == target then (target, nextState) else entry + change + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) + (nodes.map replace)) = + Option.map Prod.snd + (List.find? (fun entry => entry.1 == other) nodes) + rw [List.find?_map] + have predicate : + ((fun entry : Prod Location NodeState => entry.1 == other) ∘ + replace) = + (fun entry => entry.1 == other) := by + funext entry + by_cases atTarget : entry.1 = target + · simp [replace, atTarget] + · simp [replace, atTarget] + rw [predicate] + cases found : + List.find? (fun entry : Prod Location NodeState => + entry.1 == other) nodes with + | none => simp + | some entry => + have condition : + (entry.1 == other) = true := + List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == other) found + have entryOther : entry.1 = other := + beq_iff_eq.mp condition + have notTarget : entry.1 ≠ target := by + simpa [entryOther] using different + simp [replace, notTarget] + +lemma systemStep_node_keys_eq + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) : + after.nodes.map Prod.fst = before.nodes.map Prod.fst := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact replaceNode_keys target + (step config node event).state before.nodes + +lemma systemStep_preserves_node_locations + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (locations : + forall entry, entry ∈ before.nodes -> + entry.2.location = entry.1) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.location = entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, stateEq, _⟩ + rw [←stateEq] + apply replaceNode_locations + · exact locations + · calc + (step config node event).state.location = + node.location := step_preserves_location config node event + _ = key := + locations (key, node) (List.mem_of_find?_eq_some found) + _ = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + +lemma systemStep_other_node_eq + {config : Protocol.Config} + {before after : SystemState} + {target other : Location} + {event : Event} + {output : StepOutput} + (different : other ≠ target) + (transition : + systemStep config before target event = some (after, output)) : + (after.nodes.find? fun entry => entry.1 == other).map Prod.snd = + (before.nodes.find? fun entry => entry.1 == other).map Prod.snd := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with ⟨node, _, stateEq, _⟩ + rw [←stateEq] + exact findNode_replaceNode_ne target other + (step config node event).state before.nodes different + +lemma next_active_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.active = before.active := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, _, rfl⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, _, _, rfl⟩ + simp + +lemma next_node_keys_eq + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + after.system.nodes.map Prod.fst = + before.system.nodes.map Prod.fst := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, _, system, output, systemStep, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, system, output, systemStep, _, rfl⟩ + simpa using systemStep_node_keys_eq systemStep + +lemma retry_system_eq + {config : Config} + {before after : State} + {source : Location} + (transition : next config before (.retry source) = some after) : + after.system = before.system := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + rfl + +lemma deliver_network_eq + {config : Config} + {before after : State} + {envelope : Envelope} + (transition : next config before (.deliver envelope) = some after) : + after.network = removeOne envelope before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + simp + +lemma timeout_network_eq + {config : Config} + {before after : State} + {target : Location} + (transition : next config before (.timeout target) = some after) : + after.network = before.network := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + simp + +lemma deliver_other_node_eq + {config : Config} + {before after : State} + {envelope : Envelope} + {other : Location} + (different : other ≠ envelope.target) + (transition : next config before (.deliver envelope) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +lemma timeout_other_node_eq + {config : Config} + {before after : State} + {target other : Location} + (different : other ≠ target) + (transition : next config before (.timeout target) = some after) : + nodeState after other = nodeState before other := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + simp only [nodeState, recordEffects_system] + exact systemStep_other_node_eq different systemStep + +lemma next_sent_extends + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + exists added, after.sent = before.sent ++ added := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact ⟨retryMessages config source sourceState, rfl⟩ + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + refine ⟨[], ?_⟩ + simp + +lemma next_openings_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall opening, opening ∈ before.openings -> + opening ∈ after.openings := by + intro opening membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_openings_recordEffects + simpa using membership + +lemma next_restarts_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall restart, restart ∈ before.restarts -> + restart ∈ after.restarts := by + intro restart membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_restarts_recordEffects + simpa using membership + +lemma next_completed_monotonic + {config : Config} + {before after : State} + {action : Action} + (transition : next config before action = some after) : + forall completed, completed ∈ before.completed -> + completed ∈ after.completed := by + intro completed membership + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact membership + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, rfl⟩ + apply mem_completed_recordEffects + simpa using membership + +lemma retry_preserves_well_formed + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.retry source) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨sourceActive, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + constructor + · exact wellFormed.nodeKeys + · exact wellFormed.nodeKeysNodup + · exact wellFormed.nodeLocations + · exact wellFormed.activeNodup + · exact wellFormed.activeConfigured + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentValid envelope membership + · exact retryMessages_valid config source sourceState + sourceLocation envelope membership + · intro envelope membership + rw [List.mem_append] at membership + rcases membership with membership | membership + · exact wellFormed.sentSourceActive envelope membership + · rw [(retryMessages_source membership).1] + exact sourceActive + · intro envelope membership + rw [List.mem_append] at membership ⊢ + rcases membership with membership | membership + · exact Or.inl (wellFormed.networkSent envelope membership) + · exact Or.inr membership + · constructor + · exact wellFormed.historiesActive.openings + · exact wellFormed.historiesActive.restarts + · exact wellFormed.historiesActive.completed + +lemma deliver_preserves_well_formed + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (transition : next config before (.deliver envelope) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, targetActive, system, output, systemStep, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending + (mem_of_mem_removeOne envelope pending before.network membership) + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +lemma timeout_preserves_well_formed + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (transition : next config before (.timeout target) = some after) : + WellFormed config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨targetActive, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + constructor + · simp only [recordEffects_system] + exact (systemStep_node_keys_eq systemStep).trans + wellFormed.nodeKeys + · rw [recordEffects_system, systemStep_node_keys_eq systemStep] + exact wellFormed.nodeKeysNodup + · simp only [recordEffects_system] + exact systemStep_preserves_node_locations + wellFormed.nodeLocations systemStep + · simpa using wellFormed.activeNodup + · simpa using wellFormed.activeConfigured + · intro sent membership + rw [recordEffects_sent] at membership + exact wellFormed.sentValid sent membership + · intro sent membership + rw [recordEffects_sent] at membership + rw [recordEffects_active] + exact wellFormed.sentSourceActive sent membership + · intro pending membership + rw [recordEffects_network] at membership + rw [recordEffects_sent] + exact wellFormed.networkSent pending membership + · apply recordEffects_preserves_histories_active + · constructor + · simpa using wellFormed.historiesActive.openings + · simpa using wellFormed.historiesActive.restarts + · simpa using wellFormed.historiesActive.completed + · simpa using targetActive + +lemma next_preserves_well_formed + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (transition : next config before action = some after) : + WellFormed config after := by + cases action with + | retry source => + exact retry_preserves_well_formed wellFormed transition + | deliver envelope => + exact deliver_preserves_well_formed wellFormed transition + | timeout target => + exact timeout_preserves_well_formed wellFormed transition + +lemma reachable_well_formed + {config : Config} + {state : State} + (reachable : Reachable config state) : + WellFormed config state := by + induction reachable with + | initial active valid nodup configured => + exact initial_well_formed config active valid nodup configured + | step reachable transition wellFormed => + exact next_preserves_well_formed wellFormed transition + +lemma reachable_config_valid + {config : Config} + {state : State} + (reachable : Reachable config state) : + config.Valid := by + induction reachable with + | initial active valid nodup configured => exact valid + | step reachable transition valid => exact valid + +end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean new file mode 100644 index 00000000000..48bde6e6e2a --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean @@ -0,0 +1,1389 @@ +import DisasterRecovery.Protocol.Quorum +import DisasterRecovery.Proofs.Invariants +import Mathlib.Tactic + +/-! +Machine-checked proof implementations. Review the system-level statements in +`DisasterRecovery.Properties` and definitions in `DisasterRecovery.Protocol.Quorum`. +-/ + +namespace DisasterRecovery.Protocol.Global + +lemma insertVote_nodup + (source : Location) + {votes : List Location} + (nodup : votes.Nodup) : + (insertVote source votes).Nodup := by + unfold insertVote + split + · exact nodup + · rename_i absent + apply (List.mergeSort_perm _ _).symm.nodup + rw [List.nodup_cons] + exact + ⟨fun member => absent (List.contains_iff_mem.mpr member), nodup⟩ + +lemma mem_insertVote + {member source : Location} + {votes : List Location} + (membership : member ∈ insertVote source votes) : + member ∈ votes \/ member = source := by + unfold insertVote at membership + split at membership + · exact Or.inl membership + · have unsorted := + (List.mergeSort_perm _ _).mem_iff.mp membership + rw [List.mem_cons] at unsorted + exact unsorted.symm + +lemma step_preserves_votes_nodup + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (nodup : state.votes.Nodup) : + (step config state event).state.votes.Nodup := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals + repeat first | split | simp_all [insertVote_nodup] + +lemma step_votes_shape + (config : Protocol.Config) + (state : NodeState) + (event : Event) : + (step config state event).state.votes = state.votes \/ + exists source, + acceptedVoteSource event = some source /\ + (step config state event).state.votes = + insertVote source state.votes := by + cases event + all_goals try cases_type Validation + all_goals + simp [acceptedVoteSource, step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +lemma step_vote_origin + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (voter : Location) + (membership : voter ∈ (step config state event).state.votes) : + voter ∈ state.votes \/ + acceptedVoteSource event = some voter := by + rcases step_votes_shape config state event with + unchanged | ⟨source, sourceEq, changed⟩ + · rw [unchanged] at membership + exact Or.inl membership + · rw [changed] at membership + rcases mem_insertVote membership with old | added + · exact Or.inl old + · subst source + exact Or.inr sourceEq + +lemma step_preserves_non_gossiping + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (pastGossip : state.phase ≠ .gossiping) : + (step config state event).state.phase ≠ .gossiping := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] + all_goals repeat first | split | simp_all + +lemma voting_step_preserves_choice + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (pastGossip : state.phase ≠ .gossiping) + (stillVoting : (step config state event).state.phase = .voting) : + state.phase = .voting /\ + (step config state event).state.chosen = state.chosen := by + cases event <;> + simp [step, rejected, advance, advanceTimeoutLane] at stillVoting ⊢ + all_goals repeat first | split at stillVoting | split | simp_all + +lemma step_preserves_voting_selection + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (before : + state.phase = .voting -> + NodeVotingSelection state) + (voting : (step config state event).state.phase = .voting) : + NodeVotingSelection (step config state event).state := by + cases event + all_goals try cases_type Validation + all_goals + simp [NodeVotingSelection, step, rejected, advance, + advanceTimeoutLane, validTimeout] at before voting ⊢ + all_goals + repeat first | split at voting | split | simp_all | aesop + +lemma retry_vote_state + {config : Config} + {envelope : Envelope} + (valid : envelope.Valid config) + (vote : envelope.payload = .vote) : + envelope.sourceState.phase = .voting /\ + envelope.sourceState.chosen = some envelope.target := by + rcases valid_envelope_effect valid with + ⟨effect, member, created⟩ + cases effect with + | sendGossip target => + cases found : recoveredTxID config envelope.source with + | none => + simp [messageForEffect, found] at created + | some txid => + simp [messageForEffect, found] at created + rw [←created] at vote + contradiction + | sendVote target => + simp [messageForEffect] at created + rw [←created] at vote ⊢ + cases phase : envelope.sourceState.phase <;> + simp [step, phase] at member + next => + cases chosen : envelope.sourceState.chosen <;> + simp_all + | sendIAmOpen target => + simp [messageForEffect] at created + rw [←created] at vote + contradiction + | opening kind => + simp [messageForEffect] at created + | restart chosen => + simp [messageForEffect] at created + | completed => + simp [messageForEffect] at created + | rejected reason => + simp [messageForEffect] at created + +lemma opening_effect_state + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (kind : OpenKind) + (opening : .opening kind ∈ (step config state event).effects) : + (step config state event).state.phase = .opening /\ + (step config state event).state.openKind = some kind := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opening ⊢ + all_goals + repeat first | split at opening | split | simp_all | aesop + +lemma quorum_effect_has_threshold + (config : Protocol.Config) + (state : NodeState) + (event : Event) + (opening : + .opening .quorum ∈ (step config state event).effects) : + voteQuorum config <= + (step config state event).state.votes.length := by + cases event + all_goals try cases_type Validation + all_goals + simp [step, rejected, advance, advanceTimeoutLane, validTimeout] + at opening ⊢ + all_goals + repeat first | split at opening | split | simp_all | aesop + +lemma sentVote_mono + {before after : State} + {voter target : Location} + (sent : forall envelope, envelope ∈ before.sent -> + envelope ∈ after.sent) + (vote : SentVote before voter target) : + SentVote after voter target := by + rcases vote with + ⟨envelope, membership, source, destination, payload⟩ + exact + ⟨envelope, sent envelope membership, source, destination, payload⟩ + +lemma opening_valid_of_sent_eq + {config : Config} + {before after : State} + {opening : Opening} + (sentEq : after.sent = before.sent) + (valid : opening.Valid config before) : + opening.Valid config after := by + rcases valid with + ⟨location, phase, kind, nodup, quorum, votesSent⟩ + constructor + · exact location + · exact phase + · exact kind + · exact nodup + · exact quorum + · intro voter membership + apply sentVote_mono + · intro envelope sent + rw [sentEq] + exact sent + · exact votesSent voter membership + +lemma opening_valid_mono + {config : Config} + {before after : State} + {opening : Opening} + (sent : + forall envelope, envelope ∈ before.sent -> + envelope ∈ after.sent) + (valid : opening.Valid config before) : + opening.Valid config after := by + rcases valid with + ⟨location, phase, kind, nodup, quorum, votesSent⟩ + constructor + · exact location + · exact phase + · exact kind + · exact nodup + · exact quorum + · intro voter membership + exact sentVote_mono sent (votesSent voter membership) + +lemma recordEffect_preserves_openings_valid + {config : Config} + {node : Location} + {nodeState : NodeState} + {state : State} + {effect : Effect} + (valid : OpeningsValid config state) + (newValid : + forall kind, + effect = .opening kind -> + Opening.Valid config state + { node, kind, state := nodeState }) : + OpeningsValid config + (recordEffect node nodeState state effect) := by + intro opening membership + cases effect with + | opening kind => + simp [recordEffect] at membership + rcases membership with rfl | old + · apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.opening kind)) + rfl + exact newValid kind rfl + · apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.opening kind)) + rfl + exact valid opening old + | sendGossip target => + exact valid opening membership + | sendVote target => + exact valid opening membership + | sendIAmOpen target => + exact valid opening membership + | restart target => + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state (.restart target)) + rfl + exact valid opening membership + | completed => + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state .completed) + rfl + exact valid opening membership + | rejected reason => + exact valid opening membership + +lemma recordEffects_preserves_openings_valid + {config : Config} + {node : Location} + {nodeState : NodeState} + {state : State} + {effects : List Effect} + (valid : OpeningsValid config state) + (newValid : + forall kind, + .opening kind ∈ effects -> + Opening.Valid config state + { node, kind, state := nodeState }) : + OpeningsValid config + (recordEffects node nodeState effects state) := by + induction effects generalizing state with + | nil => exact valid + | cons effect tail ih => + simp only [recordEffects, List.foldl_cons] + apply ih + · apply recordEffect_preserves_openings_valid valid + intro kind effectEq + subst effect + exact newValid kind (by simp) + · intro kind membership + apply opening_valid_of_sent_eq + (before := state) + (after := recordEffect node nodeState state effect) + (by cases effect <;> rfl) + exact newValid kind (by simp [membership]) + +lemma eventFor_vote_source + {envelope : Envelope} + {voter : Location} + (source : + acceptedVoteSource (eventFor envelope) = some voter) : + envelope.payload = .vote /\ + envelope.source = voter := by + cases payload : envelope.payload <;> + simp_all [eventFor, acceptedVoteSource] + +lemma systemStep_preserves_votes_nodup + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (nodup : + forall entry, entry ∈ before.nodes -> + entry.2.votes.Nodup) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.votes.Nodup := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, stateEq, _⟩ + rw [←stateEq] + intro entry membership + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · apply step_preserves_votes_nodup + exact nodup (key, node) (List.mem_of_find?_eq_some found) + · exact nodup previous previousMember + +lemma systemStep_preserves_voting_selections + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (valid : + forall entry, entry ∈ before.nodes -> + entry.2.phase = .voting -> + NodeVotingSelection entry.2) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.2.phase = .voting -> + NodeVotingSelection entry.2 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership voting + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + apply step_preserves_voting_selection config node event + · exact valid (key, node) + (List.mem_of_find?_eq_some found) + · simpa [atTarget, outputEq] using voting + · rename_i notTarget + exact valid previous previousMember + (by simpa [notTarget] using voting) + +lemma systemStep_output_location + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (locations : + forall entry, entry ∈ before.nodes -> + entry.2.location = entry.1) + (transition : + systemStep config before target event = some (after, output)) : + output.state.location = target := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, _, outputEq⟩ + calc + output.state.location = + node.location := by + rw [←outputEq] + exact step_preserves_location config node event + _ = key := + locations (key, node) (List.mem_of_find?_eq_some found) + _ = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + +lemma systemStep_output_mem + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) : + (target, output.state) ∈ after.nodes := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq, replaceNode, List.mem_map] + refine ⟨(key, node), List.mem_of_find?_eq_some found, ?_⟩ + have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + simp [keyEq, outputEq] + +lemma systemStep_opening_effect_state + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {kind : OpenKind} + (transition : + systemStep config before target event = some (after, output)) + (opening : .opening kind ∈ output.effects) : + output.state.phase = .opening /\ + output.state.openKind = some kind := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, _, _, outputEq⟩ + rw [←outputEq] at opening ⊢ + exact opening_effect_state config node event kind opening + +lemma systemStep_quorum_effect_has_threshold + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + (transition : + systemStep config before target event = some (after, output)) + (opening : .opening .quorum ∈ output.effects) : + voteQuorum config <= output.state.votes.length := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, _, _, outputEq⟩ + rw [←outputEq] at opening ⊢ + exact quorum_effect_has_threshold config node event opening + +lemma initial_node_votes_nodup + (config : Config) + (active : List Location) : + NodeVotesNodup (initial config active) := by + simp [NodeVotesNodup, Global.initial, initialSystem, initialNode] + +lemma initial_node_votes_sent + (config : Config) + (active : List Location) : + NodeVotesSent (initial config active) := by + simp [NodeVotesSent, Global.initial, initialSystem, initialNode] + +lemma initial_sent_votes_functional + (config : Config) + (active : List Location) : + SentVotesFunctional (initial config active) := by + simp [SentVotesFunctional, SentVote, Global.initial] + +lemma initial_sent_vote_stable + (config : Config) + (active : List Location) : + SentVoteStable (initial config active) := by + simp [SentVoteStable, Global.initial] + +lemma initial_voting_selections + (config : Config) + (active : List Location) : + VotingSelectionsValid (initial config active) := by + simp [VotingSelectionsValid, Global.initial, initialSystem, initialNode] + +lemma initial_sent_votes_selected + (config : Config) + (active : List Location) : + SentVotesSelected (initial config active) := by + simp [SentVotesSelected, Global.initial] + +lemma initial_openings_valid + (config : Config) + (active : List Location) : + OpeningsValid config (initial config active) := by + simp [OpeningsValid, Global.initial] + +lemma systemStep_preserves_node_votes_sent + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {beforeState afterState : State} + (beforeSystem : beforeState.system = before) + (votesSent : NodeVotesSent beforeState) + (carry : + forall voter destination, + SentVote beforeState voter destination -> + SentVote afterState voter destination) + (introduced : + forall voter, + acceptedVoteSource event = some voter -> + SentVote afterState voter target) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + forall voter, voter ∈ entry.2.votes -> + SentVote afterState voter entry.1 := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership voter vote + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + have targetEq : previous.1 = target := + beq_iff_eq.mp atTarget + rcases step_vote_origin config node event voter + (by simpa [outputEq, atTarget] using vote) with + old | added + · have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + apply carry + rw [←keyEq] + exact votesSent (key, node) + (by + rw [beforeSystem] + exact List.mem_of_find?_eq_some found) + voter old + · exact introduced voter added + · rename_i notTarget + apply carry + exact votesSent previous + (by + rw [beforeSystem] + exact previousMember) + voter (by simpa [notTarget] using vote) + +lemma eq_of_key_eq + {α : Type} + {nodes : List (Prod Location α)} + (nodup : (nodes.map Prod.fst).Nodup) + {first second : Prod Location α} + (firstMember : first ∈ nodes) + (secondMember : second ∈ nodes) + (keyEq : first.1 = second.1) : + first = second := by + induction nodes generalizing first second with + | nil => simp at firstMember + | cons head tail ih => + rw [List.map_cons, List.nodup_cons] at nodup + rcases nodup with ⟨headFresh, tailNodup⟩ + rw [List.mem_cons] at firstMember secondMember + rcases firstMember with rfl | firstTail + · rcases secondMember with rfl | secondTail + · rfl + · exfalso + apply headFresh + rw [List.mem_map] + exact ⟨second, secondTail, keyEq.symm⟩ + · rcases secondMember with rfl | secondTail + · exfalso + apply headFresh + rw [List.mem_map] + exact ⟨first, firstTail, keyEq⟩ + · exact ih tailNodup firstTail secondTail keyEq + +lemma systemStep_preserves_vote_stability + {config : Protocol.Config} + {before after : SystemState} + {target : Location} + {event : Event} + {output : StepOutput} + {envelope : Envelope} + (stable : + forall entry, entry ∈ before.nodes -> + entry.1 = envelope.source -> + entry.2.phase ≠ .gossiping /\ + (entry.2.phase = .voting -> + entry.2.chosen = some envelope.target)) + (transition : + systemStep config before target event = some (after, output)) : + forall entry, entry ∈ after.nodes -> + entry.1 = envelope.source -> + entry.2.phase ≠ .gossiping /\ + (entry.2.phase = .voting -> + entry.2.chosen = some envelope.target) := by + simp [systemStep, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ + rw [←systemEq] + intro entry membership sourceEq + rw [replaceNode, List.mem_map] at membership + rcases membership with ⟨previous, previousMember, rfl⟩ + split + · rename_i atTarget + have targetEq : previous.1 = target := + beq_iff_eq.mp atTarget + have targetSource : target = envelope.source := by + simpa [atTarget] using sourceEq + have keyEq : key = target := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == target) found) + have beforeStable := + stable (key, node) (List.mem_of_find?_eq_some found) + (keyEq.trans targetSource) + constructor + · exact step_preserves_non_gossiping config node event + beforeStable.1 + · intro voting + rcases voting_step_preserves_choice config node event + beforeStable.1 voting with ⟨beforeVoting, chosenEq⟩ + rw [chosenEq] + exact beforeStable.2 beforeVoting + · rename_i notTarget + exact stable previous previousMember + (by simpa [notTarget] using sourceEq) + +lemma next_preserves_node_votes_nodup + {config : Config} + {before after : State} + {action : Action} + (nodup : NodeVotesNodup before) + (transition : next config before action = some after) : + NodeVotesNodup after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact nodup + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_votes_nodup nodup systemStep + entry membership + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership + rw [recordEffects_system] at membership + exact systemStep_preserves_votes_nodup nodup systemStep + entry membership + +lemma next_preserves_voting_selections + {config : Config} + {before after : State} + {action : Action} + (valid : VotingSelectionsValid before) + (transition : next config before action = some after) : + VotingSelectionsValid after := by + cases action with + | retry source => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + exact valid + | deliver envelope => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, rfl⟩ + intro entry membership voting + rw [recordEffects_system] at membership + exact systemStep_preserves_voting_selections valid systemStep + entry membership voting + | timeout target => + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, rfl⟩ + intro entry membership voting + rw [recordEffects_system] at membership + exact systemStep_preserves_voting_selections valid systemStep + entry membership voting + +lemma retry_preserves_sent_votes_selected + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (votingSelections : VotingSelectionsValid before) + (selected : SentVotesSelected before) + (transition : next config before (.retry source) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload + rw [List.mem_append] at membership + rcases membership with old | added + · exact selected envelope old payload + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + have identity := retryMessages_source added + rw [identity.2] at voteState + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have sourceSelection := + votingSelections entry (List.mem_of_find?_eq_some findEq) + (by simpa [stateEq] using voteState.1) + simpa [identity.2, stateEq] using sourceSelection + +lemma deliver_preserves_sent_votes_selected + {config : Config} + {before after : State} + {envelope : Envelope} + (selected : SentVotesSelected before) + (transition : next config before (.deliver envelope) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, stateEq⟩ + rw [←stateEq] + intro vote membership payload + rw [recordEffects_sent] at membership + exact selected vote membership payload + +lemma timeout_preserves_sent_votes_selected + {config : Config} + {before after : State} + {target : Location} + (selected : SentVotesSelected before) + (transition : next config before (.timeout target) = some after) : + SentVotesSelected after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, stateEq⟩ + rw [←stateEq] + intro vote membership payload + rw [recordEffects_sent] at membership + exact selected vote membership payload + +lemma retry_preserves_node_votes_sent + {config : Config} + {before after : State} + {source : Location} + (votesSent : NodeVotesSent before) + (transition : next config before (.retry source) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, rfl⟩ + intro entry membership voter vote + apply sentVote_mono (before := before) + · intro envelope sent + exact List.mem_append_left _ sent + · exact votesSent entry membership voter vote + +lemma deliver_preserves_node_votes_sent + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (votesSent : NodeVotesSent before) + (transition : next config before (.deliver envelope) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨inNetwork, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro entry membership voter vote + rw [recordEffects_system] at membership + let afterState := + recordEffects envelope.target output.state output.effects + { + before with + system + network := removeOne envelope before.network + } + have carry : + forall oldVoter oldTarget, + SentVote before oldVoter oldTarget -> + SentVote afterState oldVoter oldTarget := by + intro oldVoter oldTarget oldVote + apply sentVote_mono (before := before) (after := afterState) + · intro sent sentMember + simpa [afterState] using sentMember + · exact oldVote + have introducedVote : + forall newVoter, + acceptedVoteSource (eventFor envelope) = some newVoter -> + SentVote afterState newVoter envelope.target := by + intro newVoter introduced + rcases eventFor_vote_source introduced with + ⟨payload, source⟩ + subst newVoter + refine ⟨envelope, ?_, rfl, rfl, payload⟩ + simp [afterState] + exact wellFormed.networkSent envelope + inNetwork + exact systemStep_preserves_node_votes_sent + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl votesSent carry introducedVote systemStep + entry membership voter vote + +lemma timeout_preserves_node_votes_sent + {config : Config} + {before after : State} + {target : Location} + (votesSent : NodeVotesSent before) + (transition : next config before (.timeout target) = some after) : + NodeVotesSent after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro entry membership voter vote + rw [recordEffects_system] at membership + let afterState := + recordEffects target output.state output.effects + { before with system } + have carry : + forall oldVoter oldTarget, + SentVote before oldVoter oldTarget -> + SentVote afterState oldVoter oldTarget := by + intro oldVoter oldTarget oldVote + apply sentVote_mono (before := before) (after := afterState) + · intro sent sentMember + simpa [afterState] using sentMember + · exact oldVote + have introducedVote : + forall newVoter, + acceptedVoteSource Event.timeout = some newVoter -> + SentVote afterState newVoter target := by + intro newVoter introduced + simp [acceptedVoteSource] at introduced + exact systemStep_preserves_node_votes_sent + (before := before.system) + (after := system) + (beforeState := before) + (afterState := afterState) + rfl votesSent carry introducedVote systemStep + entry membership voter vote + +lemma retry_preserves_openings_valid + {config : Config} + {before after : State} + {source : Location} + (valid : OpeningsValid config before) + (transition : next config before (.retry source) = some after) : + OpeningsValid config after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with ⟨_, sourceState, _, _, stateEq⟩ + rw [←stateEq] + intro opening membership + apply opening_valid_mono + · intro envelope sent + exact List.mem_append_left _ sent + · exact valid opening membership + +lemma deliver_preserves_openings_valid + {config : Config} + {before after : State} + {envelope : Envelope} + (wellFormed : WellFormed config before) + (votesNodup : NodeVotesNodup before) + (votesSent : NodeVotesSent before) + (valid : OpeningsValid config before) + (transition : next config before (.deliver envelope) = some after) : + OpeningsValid config after := by + have afterNodup := + next_preserves_node_votes_nodup votesNodup transition + have afterVotesSent := + deliver_preserves_node_votes_sent wellFormed votesSent transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] at afterNodup afterVotesSent ⊢ + let delivered : State := { + before with + system + network := removeOne envelope before.network + } + apply recordEffects_preserves_openings_valid + · intro opening membership + apply opening_valid_of_sent_eq + (before := before) (after := delivered) rfl + exact valid opening membership + · intro kind openingEffect + have effectState := + systemStep_opening_effect_state systemStep openingEffect + constructor + · exact systemStep_output_location + wellFormed.nodeLocations systemStep + · exact effectState.1 + · exact effectState.2 + · apply afterNodup (envelope.target, output.state) + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · intro quorumKind + have kindEq : kind = .quorum := by simpa using quorumKind + rw [kindEq] at openingEffect + simpa using + systemStep_quorum_effect_has_threshold systemStep openingEffect + · intro voter vote + have sent := + afterVotesSent (envelope.target, output.state) + (by + rw [recordEffects_system] + exact systemStep_output_mem systemStep) + voter vote + simpa [SentVote, delivered] using sent + +lemma timeout_preserves_openings_valid + {config : Config} + {before after : State} + {target : Location} + (wellFormed : WellFormed config before) + (votesNodup : NodeVotesNodup before) + (votesSent : NodeVotesSent before) + (valid : OpeningsValid config before) + (transition : next config before (.timeout target) = some after) : + OpeningsValid config after := by + have afterNodup := + next_preserves_node_votes_nodup votesNodup transition + have afterVotesSent := + timeout_preserves_node_votes_sent votesSent transition + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] at afterNodup afterVotesSent ⊢ + let timedOut : State := { before with system } + apply recordEffects_preserves_openings_valid + · intro opening membership + apply opening_valid_of_sent_eq + (before := before) (after := timedOut) rfl + exact valid opening membership + · intro kind openingEffect + have effectState := + systemStep_opening_effect_state systemStep openingEffect + constructor + · exact systemStep_output_location + wellFormed.nodeLocations systemStep + · exact effectState.1 + · exact effectState.2 + · apply afterNodup (target, output.state) + rw [recordEffects_system] + exact systemStep_output_mem systemStep + · intro quorumKind + have kindEq : kind = .quorum := by simpa using quorumKind + rw [kindEq] at openingEffect + simpa using + systemStep_quorum_effect_has_threshold systemStep openingEffect + · intro voter vote + have sent := + afterVotesSent (target, output.state) + (by + rw [recordEffects_system] + exact systemStep_output_mem systemStep) + voter vote + simpa [SentVote, timedOut] using sent + +lemma retry_preserves_sent_vote_stable + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (stable : SentVoteStable before) + (transition : next config before (.retry source) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [List.mem_append] at membership + rcases membership with old | added + · exact stable envelope old payload entry entryMember keyEq + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + rcases retryMessages_source added with + ⟨sourceEq, stateEq⟩ + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨foundEntry, findEq, foundStateEq⟩ + have foundMember : foundEntry ∈ before.system.nodes := + List.mem_of_find?_eq_some findEq + have foundKey : foundEntry.1 = source := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == source) findEq) + have sameEntry : entry = foundEntry := + eq_of_key_eq wellFormed.nodeKeysNodup entryMember foundMember + ((keyEq.trans sourceEq).trans foundKey.symm) + subst entry + rw [foundStateEq, ←stateEq] + exact ⟨by simp [voteState.1], fun _ => voteState.2⟩ + +lemma deliver_preserves_sent_vote_stable + {config : Config} + {before after : State} + {delivered : Envelope} + (stable : SentVoteStable before) + (transition : next config before (.deliver delivered) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, systemStep, stateEq⟩ + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [recordEffects_sent] at membership + rw [recordEffects_system] at entryMember + exact systemStep_preserves_vote_stability + (fun previous previousMember source => + stable envelope membership payload previous previousMember source) + systemStep entry entryMember keyEq + +lemma timeout_preserves_sent_vote_stable + {config : Config} + {before after : State} + {target : Location} + (stable : SentVoteStable before) + (transition : next config before (.timeout target) = some after) : + SentVoteStable after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, systemStep, _, stateEq⟩ + rw [←stateEq] + intro envelope membership payload entry entryMember keyEq + rw [recordEffects_sent] at membership + rw [recordEffects_system] at entryMember + exact systemStep_preserves_vote_stability + (fun previous previousMember source => + stable envelope membership payload previous previousMember source) + systemStep entry entryMember keyEq + +lemma sentVote_stable_at_node + {state : State} + {voter target : Location} + {current : NodeState} + (stable : SentVoteStable state) + (vote : SentVote state voter target) + (found : nodeState state voter = some current) : + current.phase ≠ .gossiping /\ + (current.phase = .voting -> + current.chosen = some target) := by + rcases vote with + ⟨envelope, sent, sourceEq, targetEq, payload⟩ + rw [nodeState, Option.map_eq_some_iff] at found + rcases found with ⟨entry, findEq, stateEq⟩ + have entryMember : entry ∈ state.system.nodes := + List.mem_of_find?_eq_some findEq + have entryKey : entry.1 = voter := + beq_iff_eq.mp + (List.find?_some + (p := fun entry : Prod Location NodeState => + entry.1 == voter) findEq) + have result := + stable envelope sent payload entry entryMember + (entryKey.trans sourceEq.symm) + rw [stateEq] at result + simpa [targetEq] using result + +lemma retry_preserves_sent_votes_functional + {config : Config} + {before after : State} + {source : Location} + (wellFormed : WellFormed config before) + (functional : SentVotesFunctional before) + (stable : SentVoteStable before) + (transition : next config before (.retry source) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, sourceState, found, _, stateEq⟩ + have sourceLocation : sourceState.location = source := + nodeState_location wellFormed.nodeLocations found + rw [←stateEq] + have classify : + forall voter target, + SentVote + { + before with + network := before.network ++ + retryMessages config source sourceState + sent := before.sent ++ + retryMessages config source sourceState + } + voter target -> + SentVote before voter target \/ + (voter = source /\ + sourceState.phase = .voting /\ + sourceState.chosen = some target) := by + intro voter target vote + rcases vote with + ⟨envelope, membership, sourceEq, targetEq, payload⟩ + rw [List.mem_append] at membership + rcases membership with old | added + · exact Or.inl + ⟨envelope, old, sourceEq, targetEq, payload⟩ + · have valid : envelope.Valid config := + retryMessages_valid config source sourceState sourceLocation + envelope added + have voteState := retry_vote_state valid payload + have retryIdentity := retryMessages_source added + rw [retryIdentity.2] at voteState + exact Or.inr + ⟨sourceEq.symm.trans retryIdentity.1, + voteState.1, + by simpa [targetEq] using voteState.2⟩ + intro voter first second firstVote secondVote + rcases classify voter first firstVote with + firstOld | ⟨firstSource, firstPhase, firstChoice⟩ + · rcases classify voter second secondVote with + secondOld | ⟨secondSource, secondPhase, secondChoice⟩ + · exact functional voter first second firstOld secondOld + · have oldState := + sentVote_stable_at_node stable firstOld + (by simpa [secondSource] using found) + have oldChoice := oldState.2 secondPhase + rw [oldChoice] at secondChoice + exact Option.some.inj secondChoice + · rcases classify voter second secondVote with + secondOld | ⟨secondSource, secondPhase, secondChoice⟩ + · have oldState := + sentVote_stable_at_node stable secondOld + (by simpa [firstSource] using found) + have oldChoice := oldState.2 firstPhase + rw [oldChoice] at firstChoice + exact (Option.some.inj firstChoice).symm + · rw [firstChoice] at secondChoice + exact Option.some.inj secondChoice + +lemma deliver_preserves_sent_votes_functional + {config : Config} + {before after : State} + {envelope : Envelope} + (functional : SentVotesFunctional before) + (transition : next config before (.deliver envelope) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, _, system, output, _, stateEq⟩ + rw [←stateEq] + intro voter first second firstVote secondVote + apply functional voter first second + · simpa [SentVote] using firstVote + · simpa [SentVote] using secondVote + +lemma timeout_preserves_sent_votes_functional + {config : Config} + {before after : State} + {target : Location} + (functional : SentVotesFunctional before) + (transition : next config before (.timeout target) = some after) : + SentVotesFunctional after := by + simp [next, Option.bind_eq_some_iff] at transition + rcases transition with + ⟨_, system, output, _, _, stateEq⟩ + rw [←stateEq] + intro voter first second firstVote secondVote + apply functional voter first second + · simpa [SentVote] using firstVote + · simpa [SentVote] using secondVote + +lemma initial_quorum_invariant + (config : Config) + (active : List Location) : + QuorumInvariant config (initial config active) := { + votesNodup := initial_node_votes_nodup config active + votesSent := initial_node_votes_sent config active + sentVoteStable := initial_sent_vote_stable config active + sentVotesFunctional := initial_sent_votes_functional config active + votingSelections := initial_voting_selections config active + sentVotesSelected := initial_sent_votes_selected config active + openingsValid := initial_openings_valid config active +} + +lemma next_preserves_quorum_invariant + {config : Config} + {before after : State} + {action : Action} + (wellFormed : WellFormed config before) + (invariant : QuorumInvariant config before) + (transition : next config before action = some after) : + QuorumInvariant config after := by + cases action with + | retry source => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact retry_preserves_node_votes_sent + invariant.votesSent transition + · exact retry_preserves_sent_vote_stable + wellFormed invariant.sentVoteStable transition + · exact retry_preserves_sent_votes_functional + wellFormed invariant.sentVotesFunctional + invariant.sentVoteStable transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact retry_preserves_sent_votes_selected + wellFormed invariant.votingSelections + invariant.sentVotesSelected transition + · exact retry_preserves_openings_valid + invariant.openingsValid transition + | deliver envelope => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact deliver_preserves_node_votes_sent + wellFormed invariant.votesSent transition + · exact deliver_preserves_sent_vote_stable + invariant.sentVoteStable transition + · exact deliver_preserves_sent_votes_functional + invariant.sentVotesFunctional transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact deliver_preserves_sent_votes_selected + invariant.sentVotesSelected transition + · exact deliver_preserves_openings_valid + wellFormed invariant.votesNodup invariant.votesSent + invariant.openingsValid transition + | timeout target => + constructor + · exact next_preserves_node_votes_nodup + invariant.votesNodup transition + · exact timeout_preserves_node_votes_sent + invariant.votesSent transition + · exact timeout_preserves_sent_vote_stable + invariant.sentVoteStable transition + · exact timeout_preserves_sent_votes_functional + invariant.sentVotesFunctional transition + · exact next_preserves_voting_selections + invariant.votingSelections transition + · exact timeout_preserves_sent_votes_selected + invariant.sentVotesSelected transition + · exact timeout_preserves_openings_valid + wellFormed invariant.votesNodup invariant.votesSent + invariant.openingsValid transition + +lemma reachable_quorum_invariant + {config : Config} + {state : State} + (reachable : Reachable config state) : + QuorumInvariant config state := by + induction reachable with + | initial active valid nodup configured => + exact initial_quorum_invariant config active + | step reachable transition invariant => + exact next_preserves_quorum_invariant + (reachable_well_formed reachable) invariant transition + +lemma quorum_lists_intersect + {α : Type} + [DecidableEq α] + (expected first second : List α) + (firstNodup : first.Nodup) + (secondNodup : second.Nodup) + (firstSubset : + forall value, value ∈ first -> value ∈ expected) + (secondSubset : + forall value, value ∈ second -> value ∈ expected) + (firstQuorum : + expected.length / 2 + 1 <= first.length) + (secondQuorum : + expected.length / 2 + 1 <= second.length) : + exists value, value ∈ first /\ value ∈ second := by + by_contra noShared + push_neg at noShared + have disjoint : Disjoint first.toFinset second.toFinset := + Finset.disjoint_left.mpr (by + intro value firstMember secondMember + exact noShared value + (List.mem_toFinset.mp firstMember) + (List.mem_toFinset.mp secondMember)) + have unionSubset : + first.toFinset ∪ second.toFinset ⊆ expected.toFinset := by + intro value membership + rw [Finset.mem_union] at membership + rw [List.mem_toFinset] + exact membership.elim + (fun member => + firstSubset value (List.mem_toFinset.mp member)) + (fun member => + secondSubset value (List.mem_toFinset.mp member)) + have unionCard := Finset.card_le_card unionSubset + rw [Finset.card_union_of_disjoint disjoint, + List.toFinset_card_of_nodup firstNodup, + List.toFinset_card_of_nodup secondNodup] at unionCard + have expectedCard := List.toFinset_card_le expected + omega + +lemma opening_vote_configured + {config : Config} + {state : State} + {opening : Opening} + (wellFormed : WellFormed config state) + (valid : opening.Valid config state) + {voter : Location} + (vote : voter ∈ opening.state.votes) : + voter ∈ config.protocol.expectedLocations := by + rcases valid.votesSent voter vote with + ⟨envelope, sent, sourceEq, _, _⟩ + apply wellFormed.activeConfigured voter + simpa [sourceEq] using + wellFormed.sentSourceActive envelope sent + +lemma quorum_opener_unique + {config : Config} + {state : State} + {first second : Location} + (reachable : Reachable config state) + (firstOpened : QuorumOpened state first) + (secondOpened : QuorumOpened state second) : + first = second := by + have wellFormed := reachable_well_formed reachable + have invariant := reachable_quorum_invariant reachable + rcases firstOpened with + ⟨firstOpening, firstMember, firstNode, firstKind⟩ + rcases secondOpened with + ⟨secondOpening, secondMember, secondNode, secondKind⟩ + have firstValid := + invariant.openingsValid firstOpening firstMember + have secondValid := + invariant.openingsValid secondOpening secondMember + rcases quorum_lists_intersect + config.protocol.expectedLocations + firstOpening.state.votes + secondOpening.state.votes + firstValid.votesNodup + secondValid.votesNodup + (fun voter vote => + opening_vote_configured wellFormed firstValid vote) + (fun voter vote => + opening_vote_configured wellFormed secondValid vote) + (by + simpa [voteQuorum] using firstValid.quorum firstKind) + (by + simpa [voteQuorum] using secondValid.quorum secondKind) with + ⟨voter, firstVote, secondVote⟩ + have targetEq := + invariant.sentVotesFunctional voter + firstOpening.node secondOpening.node + (firstValid.votesSent voter firstVote) + (secondValid.votesSent voter secondVote) + exact firstNode.symm.trans (targetEq.trans secondNode) + +end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/Temporal.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/Temporal.lean new file mode 100644 index 00000000000..cb1a9cab53c --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/Temporal.lean @@ -0,0 +1,197 @@ +import DisasterRecovery.Protocol.Temporal +import Mathlib.Tactic.Lemma + +/-! +Machine-checked proof implementations. Review the system-level statements in +`DisasterRecovery.Properties` and definitions in `DisasterRecovery.Protocol.Temporal`. +-/ + +namespace DisasterRecovery.Protocol + +lemma valid_timeout_requires_alignment + (state : NodeState) + (h : validTimeout state true = true) : + state.phase = state.timeoutState := by + simpa [validTimeout] using h + +lemma gossip_freezes_after_choice + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) + (h : state.chosen.isSome = true) : + let output := step config state (.receiveGossip source txid .accepted) + output.state = state /\ output.accepted = false := by + cases chosen : state.chosen <;> simp_all [step, rejected] + +lemma rejected_gossip_stutters + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) : + let output := step config state (.receiveGossip source txid .rejected) + output.state = state /\ output.accepted = false := by + simp [step, rejected] + +lemma duplicate_vote_is_idempotent + (source : Location) + (votes : List Location) + (h : votes.contains source = true) : + insertVote source votes = votes := by + unfold insertVote + rw [h] + simp + +lemma opening_rejects_iamopen + (config : Config) + (state : NodeState) + (source : Location) : + let opening := { state with phase := .opening } + let output := step config opening (.receiveIAmOpen source .accepted) + output.state = opening /\ output.accepted = false := by + simp [step, rejected] + +lemma open_rejects_iamopen + (config : Config) + (state : NodeState) + (source : Location) : + let opened := { state with phase := .open } + let output := step config opened (.receiveIAmOpen source .accepted) + output.state = opened /\ output.accepted = false := by + simp [step, rejected] + +lemma aligned_voting_timeout_without_votes_stutters + (config : Config) + (state : NodeState) : + let waiting := { + state with + phase := .voting + timeoutState := .voting + votes := [] + } + step config waiting .timeout = { state := waiting } := by + simp [step, advance, validTimeout, voteQuorum] + +lemma aligned_opening_timeout_completes + (config : Config) + (state : NodeState) : + let opening := { + state with + phase := .opening + timeoutState := .opening + } + let output := step config opening .timeout + output.state.phase = .open /\ + output.state.timeoutState = .opening /\ + output.effects = [.completed] := by + simp [step, advance, validTimeout, advanceTimeoutLane, advanceTimeoutState] + +lemma quorum_advance_opens + (config : Config) + (state : NodeState) + (phase : state.phase = .voting) + (quorum : state.votes.length >= voteQuorum config) : + let output := (advance config state false).get! + output.state.phase = .opening /\ + output.state.openKind = some .quorum /\ + output.effects = [.opening .quorum] := by + simp [advance, phase, quorum, validTimeout, advanceTimeoutLane] + +lemma aligned_empty_gossip_timeout_aborts + (config : Config) + (state : NodeState) : + let waiting := { + state with + phase := .gossiping + timeoutState := .gossiping + gossips := [] + } + let output := step config waiting .timeout + output.state = waiting /\ output.accepted = false := by + simp [step, advance, validTimeout, rejected, maximumGossip] + +lemma non_timeout_step_preserves_aligned_opening + (config : Config) + (state : NodeState) + (event : Event) + (aligned : AlignedOpening state) + (notTimeout : Not (event = .timeout)) : + AlignedOpening (step config state event).state := by + have phase := aligned.1 + have timeoutState := aligned.2 + cases event with + | receiveGossip source txid validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected, advance, validTimeout, + advanceTimeoutLane] + split <;> simp_all + | receiveVote source validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected, advance, validTimeout, + advanceTimeoutLane] + | receiveIAmOpen source validation => + cases validation <;> + simp_all [AlignedOpening, step, rejected] + | timeout => + exact (notTimeout rfl).elim + | retry => + simp [AlignedOpening, step, phase, timeoutState] + +lemma aligned_timeout_transitions_to_open + (config : Config) + (state : NodeState) + (aligned : AlignedOpening state) : + (step config state .timeout).state.phase = .open := by + have phase := aligned.1 + have timeoutState := aligned.2 + simp [step, advance, validTimeout, phase, timeoutState, + advanceTimeoutLane, advanceTimeoutState] + +lemma fairness_supplies_firing + {config : Config} + (execution : Execution config) + (enabled : NodeState -> Prop) + (fired : NodeState -> Event -> Prop) + (fair : WeakFairness execution enabled fired) + (alwaysEnabled : forall n, enabled (execution.states n)) : + InfinitelyOften + (fun n => fired (execution.states n) (execution.events n)) := by + intro start + exact fair start (fun n _ => alwaysEnabled n) + +lemma fair_aligned_opening_progress + {config : Config} + (execution : Execution config) + (initial : AlignedOpening (execution.states 0)) + (fair : WeakFairness execution AlignedOpening + (fun _ event => event = .timeout)) : + EventuallyFrom 0 + (fun n => (execution.states n).phase = .open) := by + apply Classical.byContradiction + intro noOpen + have neverOpen : + forall n, Not ((execution.states n).phase = .open) := by + intro n opened + apply noOpen + exact Exists.intro n (And.intro (Nat.zero_le n) opened) + have alignedAlways : forall n, AlignedOpening (execution.states n) := by + intro n + induction n with + | zero => exact initial + | succ n aligned => + have notTimeout : Not (execution.events n = .timeout) := by + intro timeout + apply neverOpen (n + 1) + rw [execution.step_succ n, timeout] + exact aligned_timeout_transitions_to_open config _ aligned + rw [execution.step_succ n] + exact non_timeout_step_preserves_aligned_opening + config _ _ aligned notTimeout + have firing := fair 0 (fun n _ => alignedAlways n) + let n := firing.choose + have timeout := firing.choose_spec.2 + apply neverOpen (n + 1) + rw [execution.step_succ n, timeout] + exact aligned_timeout_transitions_to_open config _ (alignedAlways n) + +end DisasterRecovery.Protocol \ No newline at end of file diff --git a/lean/disaster-recovery/DisasterRecovery/Properties.lean b/lean/disaster-recovery/DisasterRecovery/Properties.lean new file mode 100644 index 00000000000..17854b30611 --- /dev/null +++ b/lean/disaster-recovery/DisasterRecovery/Properties.lean @@ -0,0 +1,209 @@ +import DisasterRecovery.Proofs.GlobalTemporal + +/-! +# Human-reviewed system properties + +Review these statements together with the definitions and assumptions in +`DisasterRecovery.Protocol`. Each theorem explicitly applies a machine-checked +lemma from `DisasterRecovery.Proofs`; changing a statement must preserve that +checked connection. Intermediate facts remain lemmas in the proof modules. +-/ + +namespace DisasterRecovery.Protocol.Properties + +/-! ## Local safety and progress -/ + +theorem gossip_freezes_after_choice + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) + (chosen : state.chosen.isSome = true) : + let output := step config state (.receiveGossip source txid .accepted) + output.state = state /\ output.accepted = false := + DisasterRecovery.Protocol.gossip_freezes_after_choice config state source txid chosen + +theorem rejected_gossip_stutters + (config : Config) + (state : NodeState) + (source : Location) + (txid : TxID) : + let output := step config state (.receiveGossip source txid .rejected) + output.state = state /\ output.accepted = false := + DisasterRecovery.Protocol.rejected_gossip_stutters config state source txid + +theorem quorum_advance_opens + (config : Config) + (state : NodeState) + (phase : state.phase = .voting) + (quorum : state.votes.length >= voteQuorum config) : + let output := (advance config state false).get! + output.state.phase = .opening /\ + output.state.openKind = some .quorum /\ + output.effects = [.opening .quorum] := + DisasterRecovery.Protocol.quorum_advance_opens config state phase quorum + +theorem aligned_opening_timeout_completes + (config : Config) + (state : NodeState) : + let opening := { + state with + phase := .opening + timeoutState := .opening + } + let output := step config opening .timeout + output.state.phase = .open /\ + output.state.timeoutState = .opening /\ + output.effects = [.completed] := + DisasterRecovery.Protocol.aligned_opening_timeout_completes config state + +theorem fair_aligned_opening_progress + {config : Config} + (execution : Execution config) + (initial : AlignedOpening (execution.states 0)) + (fair : WeakFairness execution AlignedOpening + (fun _ event => event = .timeout)) : + EventuallyFrom 0 + (fun n => (execution.states n).phase = .open) := + DisasterRecovery.Protocol.fair_aligned_opening_progress execution initial fair + +end DisasterRecovery.Protocol.Properties + +namespace DisasterRecovery.Protocol.Global.Properties + +/-! ## Reachability and quorum safety -/ + +theorem reachable_well_formed + {config : Config} + {state : State} + (reachable : Reachable config state) : + WellFormed config state := + DisasterRecovery.Protocol.Global.reachable_well_formed reachable + +theorem reachable_quorum_invariant + {config : Config} + {state : State} + (reachable : Reachable config state) : + QuorumInvariant config state := + DisasterRecovery.Protocol.Global.reachable_quorum_invariant reachable + +theorem quorum_opener_unique + {config : Config} + {state : State} + {first second : Location} + (reachable : Reachable config state) + (firstOpened : QuorumOpened state first) + (secondOpened : QuorumOpened state second) : + first = second := + DisasterRecovery.Protocol.Global.quorum_opener_unique + reachable firstOpened secondOpened + +/-! ## Committed-prefix safety -/ + +theorem full_gossip_selection_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := + DisasterRecovery.Protocol.Global.full_gossip_selection_preserves_commit + reachable full durable + +theorem quorum_open_preserves_commit + {config : Config} + {state : State} + {opener : Location} + {committed : TxID} + (reachable : Reachable config state) + (opened : QuorumOpened state opener) + (full : FullGossipSelection config state opener) + (durable : DurableCommit config committed) : + exists recovered, + recoveredTxID config opener = some recovered /\ + TxID.PrefixOf committed recovered := + DisasterRecovery.Protocol.Global.quorum_open_preserves_commit + reachable opened full durable + +/-! ## Conditional global progress -/ + +theorem fair_opening_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + {start : Nat} + {node : Location} + (active : node ∈ (execution.states start).active) + (phase : HasPhase (execution.states start) node .opening) : + EventuallyFrom start (fun n => + CompletedOpen (execution.states n) node) := + DisasterRecovery.Protocol.Global.fair_opening_completes + execution initial fair active phase + +theorem fair_some_opener_completes + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) := + DisasterRecovery.Protocol.Global.fair_some_opener_completes + execution initial fair activeNonempty + +theorem global_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + (activeNonempty : (execution.states 0).active ≠ []) : + EventuallyFrom 0 (fun n => + exists node, CompletedOpen (execution.states n) node) /\ + EventuallyFrom 0 (fun n => + forall node, node ∈ (execution.states 0).active -> + Terminal (execution.states n) node) := + DisasterRecovery.Protocol.Global.global_progress + execution initial fair broadcast activeNonempty + +theorem single_completion_path_joins_others + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (completed : CompletedOpen (execution.states start) opener) + (onlyOpener : OnlyOpenerCompletesFrom execution start opener) : + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := + DisasterRecovery.Protocol.Global.single_completion_path_joins_others + execution initial fair broadcast completed onlyOpener + +theorem quorum_path_progress + {config : Config} + (execution : Execution config) + (initial : Reachable config (execution.states 0)) + (fair : Fair execution) + (broadcast : BroadcastBeforeCompletion execution) + {start : Nat} + {opener : Location} + (opened : QuorumOpened (execution.states start) opener) + (completed : CompletedOpen (execution.states start) opener) + (quorumOnly : QuorumOnlyCompletions execution) : + QuorumOpened (execution.states start) opener /\ + CompletedOpen (execution.states start) opener /\ + EventuallyFrom start (fun n => + forall node, node ∈ (execution.states start).active -> + node = opener \/ node ∈ (execution.states n).restarts) := + DisasterRecovery.Protocol.Global.quorum_path_progress + execution initial fair broadcast opened completed quorumOnly + +end DisasterRecovery.Protocol.Global.Properties diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean index aeaec563bea..142d2a0735e 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Committed.lean @@ -1,5 +1,6 @@ import DisasterRecovery.Protocol.Quorum -import Mathlib.Tactic + +/-! Human-reviewed committed-prefix ordering and completeness assumptions. -/ namespace DisasterRecovery.Protocol @@ -9,172 +10,10 @@ def PrefixOf (left right : TxID) : Prop := left.view < right.view \/ (left.view = right.view /\ left.seqno <= right.seqno) -theorem prefix_refl (txid : TxID) : PrefixOf txid txid := by - simp [PrefixOf] - -theorem prefix_trans - {first second third : TxID} - (firstSecond : PrefixOf first second) - (secondThird : PrefixOf second third) : - PrefixOf first third := by - simp [PrefixOf] at firstSecond secondThird ⊢ - omega - end TxID namespace Global -theorem prefix_of_score_true - (leftName rightName : Location) - (left right : TxID) - (score : - txScoreGreater leftName left rightName right = true) : - TxID.PrefixOf right left := by - simp [txScoreGreater] at score - simp [TxID.PrefixOf] - omega - -theorem prefix_of_score_false - (leftName rightName : Location) - (left right : TxID) - (score : - txScoreGreater leftName left rightName right = false) : - TxID.PrefixOf left right := by - simp [txScoreGreater] at score - simp [TxID.PrefixOf] - omega - -theorem current_prefix_selectMaximum - (current candidate : Prod Location TxID) : - TxID.PrefixOf current.2 - (selectMaximum current candidate).2 := by - unfold selectMaximum - split - · rename_i score - exact prefix_of_score_true - candidate.1 current.1 candidate.2 current.2 score - · exact TxID.prefix_refl current.2 - -theorem candidate_prefix_selectMaximum - (current candidate : Prod Location TxID) : - TxID.PrefixOf candidate.2 - (selectMaximum current candidate).2 := by - unfold selectMaximum - split - · exact TxID.prefix_refl candidate.2 - · rename_i score - exact prefix_of_score_false - candidate.1 current.1 candidate.2 current.2 - (Bool.eq_false_iff.mpr score) - -theorem foldl_selectMaximum_upper_bound - (current member : Prod Location TxID) - (tail : List (Prod Location TxID)) - (membership : member = current \/ member ∈ tail) : - TxID.PrefixOf member.2 - (tail.foldl selectMaximum current).2 := by - induction tail generalizing current member with - | nil => - simp at membership - subst member - exact TxID.prefix_refl current.2 - | cons candidate rest ih => - simp only [List.foldl_cons] - rcases membership with currentMember | tailMember - · subst member - exact TxID.prefix_trans - (current_prefix_selectMaximum current candidate) - (ih (selectMaximum current candidate) - (selectMaximum current candidate) (Or.inl rfl)) - · rw [List.mem_cons] at tailMember - rcases tailMember with candidateMember | restMember - · subst member - exact TxID.prefix_trans - (candidate_prefix_selectMaximum current candidate) - (ih (selectMaximum current candidate) - (selectMaximum current candidate) (Or.inl rfl)) - · exact ih (selectMaximum current candidate) member - (Or.inr restMember) - -theorem maximumGossip_upper_bound - {gossips : List (Prod Location TxID)} - {selected member : Prod Location TxID} - (maximum : maximumGossip gossips = some selected) - (membership : member ∈ gossips) : - TxID.PrefixOf member.2 selected.2 := by - cases gossips with - | nil => simp at membership - | cons head tail => - simp [maximumGossip] at maximum - rw [←maximum] - apply foldl_selectMaximum_upper_bound head member tail - simpa using membership - -theorem foldl_selectMaximum_mem - (current : Prod Location TxID) - (tail : List (Prod Location TxID)) : - tail.foldl selectMaximum current ∈ current :: tail := by - induction tail generalizing current with - | nil => simp - | cons candidate rest ih => - simp only [List.foldl_cons] - have selected : - selectMaximum current candidate = current \/ - selectMaximum current candidate = candidate := by - unfold selectMaximum - split <;> simp - have member := - ih (selectMaximum current candidate) - rw [List.mem_cons] at member - rcases member with currentMember | restMember - · rw [currentMember] - rcases selected with selected | selected - · simp [selected] - · simp [selected] - · simp [restMember] - -theorem maximumGossip_mem - {gossips : List (Prod Location TxID)} - {selected : Prod Location TxID} - (maximum : maximumGossip gossips = some selected) : - selected ∈ gossips := by - cases gossips with - | nil => simp [maximumGossip] at maximum - | cons head tail => - simp [maximumGossip] at maximum - rw [←maximum] - exact foldl_selectMaximum_mem head tail - -theorem recoveredTxID_of_mem - {config : Config} - {location : Location} - {txid : TxID} - (valid : config.Valid) - (membership : (location, txid) ∈ config.recovered) : - recoveredTxID config location = some txid := by - have keysNodup : (config.recovered.map Prod.fst).Nodup := by - rw [valid.2.2] - exact valid.2.1 - unfold recoveredTxID - cases found : - config.recovered.find? fun entry => entry.1 == location with - | none => - rw [List.find?_eq_none] at found - exact False.elim - (found (location, txid) membership (by simp)) - | some entry => - have foundMember : entry ∈ config.recovered := - List.mem_of_find?_eq_some found - have foundLocation : entry.1 = location := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location TxID => - entry.1 == location) found) - have same : - entry = (location, txid) := - eq_of_key_eq keysNodup foundMember membership foundLocation - simp [same] - def FullGossipSelection (config : Config) (state : State) @@ -192,67 +31,6 @@ def DurableCommit (config : Config) (committed : TxID) : Prop := (location, txid) ∈ config.recovered /\ TxID.PrefixOf committed txid -theorem full_gossip_selection_preserves_commit - {config : Config} - {state : State} - {opener : Location} - {committed : TxID} - (reachable : Reachable config state) - (full : FullGossipSelection config state opener) - (durable : DurableCommit config committed) : - exists recovered, - recoveredTxID config opener = some recovered /\ - TxID.PrefixOf committed recovered := by - have configValid := reachable_config_valid reachable - have wellFormed := reachable_well_formed reachable - have invariant := reachable_quorum_invariant reachable - rcases full with - ⟨vote, sent, payload, target, complete⟩ - have voteState := - retry_vote_state (wellFormed.sentValid vote sent) payload - rcases invariant.sentVotesSelected vote sent payload with - ⟨selectedTarget, selectedTxID, choice, selected⟩ - have selectedTargetEq : selectedTarget = vote.target := - Option.some.inj (choice.symm.trans voteState.2) - rw [selectedTargetEq, target] at selected - rcases durable with - ⟨durableLocation, durableTxID, durableMember, committedDurable⟩ - have durableGossip : - (durableLocation, durableTxID) ∈ vote.sourceState.gossips := - (complete (durableLocation, durableTxID)).2 durableMember - have durableMaximum := - maximumGossip_upper_bound selected durableGossip - have selectedGossip : - (opener, selectedTxID) ∈ vote.sourceState.gossips := - maximumGossip_mem selected - have selectedRecovered : - (opener, selectedTxID) ∈ config.recovered := - (complete (opener, selectedTxID)).1 selectedGossip - exact - ⟨selectedTxID, - recoveredTxID_of_mem configValid selectedRecovered, - TxID.prefix_trans committedDurable durableMaximum⟩ - -/-- -Quorum opening scopes the result to an actual decision, while the separate -`FullGossipSelection` premise carries the completeness requirement. Quorum -opening alone does not imply complete gossip because voting may follow a -gossip timeout. --/ -theorem quorum_open_preserves_commit - {config : Config} - {state : State} - {opener : Location} - {committed : TxID} - (reachable : Reachable config state) - (_opened : QuorumOpened state opener) - (full : FullGossipSelection config state opener) - (durable : DurableCommit config committed) : - exists recovered, - recoveredTxID config opener = some recovered /\ - TxID.PrefixOf committed recovered := - full_gossip_selection_preserves_commit reachable full durable - end Global end DisasterRecovery.Protocol diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean index c7cac044b5f..de535ee12fd 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/GlobalTemporal.lean @@ -1,6 +1,7 @@ import DisasterRecovery.Protocol.Committed import DisasterRecovery.Protocol.Temporal -import Mathlib.Tactic + +/-! Human-reviewed global execution, termination and fairness assumptions. -/ namespace DisasterRecovery.Protocol.Global @@ -30,20 +31,6 @@ def LaneAdvanced (state : State) (node : Location) : Prop := Global.nodeState state node = some nodeState /\ nodeState.timeoutState ≠ .gossiping -theorem hasPhase_unique - {state : State} - {node : Location} - {first second : Phase} - (firstPhase : HasPhase state node first) - (secondPhase : HasPhase state node second) : - first = second := by - rcases firstPhase with ⟨firstState, firstFound, firstEq⟩ - rcases secondPhase with ⟨secondState, secondFound, secondEq⟩ - rw [firstFound] at secondFound - injection secondFound with stateEq - subst secondState - exact firstEq.symm.trans secondEq - def Terminal (state : State) (node : Location) : Prop := node ∈ state.restarts \/ node ∈ state.completed @@ -144,269 +131,6 @@ def NodeLanesValid (state : State) : Prop := forall entry, entry ∈ state.system.nodes -> LaneValid entry.2 -theorem step_preserves_lane - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (valid : LaneValid state) : - LaneValid (step config state event).state := by - cases event - all_goals try cases_type Validation - all_goals - simp [LaneValid, step, rejected, advance, advanceTimeoutLane, - advanceTimeoutState, validTimeout] at valid ⊢ - all_goals repeat first | split | simp_all | aesop - -theorem step_preserves_advanced_lane - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (advanced : state.timeoutState ≠ .gossiping) : - (step config state event).state.timeoutState ≠ .gossiping := by - cases event - all_goals try cases_type Validation - all_goals - simp [step, rejected, advance, validTimeout, advanceTimeoutLane, - advanceTimeoutState] at advanced ⊢ - all_goals repeat first | split | simp_all - -theorem systemStep_preserves_lanes - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (valid : - forall entry, entry ∈ before.nodes -> - LaneValid entry.2) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - LaneValid entry.2 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · apply step_preserves_lane config node event - exact valid (key, node) (List.mem_of_find?_eq_some found) - · exact valid previous previousMember - -theorem initial_lanes_valid - (config : Config) - (active : List Location) : - NodeLanesValid (initial config active) := by - simp [NodeLanesValid, LaneValid, Global.initial, initialSystem, - initialNode] - -theorem next_preserves_lanes - {config : Config} - {before after : State} - {action : Action} - (valid : NodeLanesValid before) - (transition : next config before action = some after) : - NodeLanesValid after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact valid - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, rfl⟩ - intro entry membership - rw [recordEffects_system] at membership - exact systemStep_preserves_lanes valid systemStep - entry membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, rfl⟩ - intro entry membership - rw [recordEffects_system] at membership - exact systemStep_preserves_lanes valid systemStep - entry membership - -theorem reachable_lanes_valid - {config : Config} - {state : State} - (reachable : Reachable config state) : - NodeLanesValid state := by - induction reachable with - | initial active valid nodup configured => - exact initial_lanes_valid config active - | step reachable transition valid => - exact next_preserves_lanes valid transition - -theorem nodeState_eq_of_mem - {state : State} - {node : Location} - {foundState : NodeState} - (keysNodup : (state.system.nodes.map Prod.fst).Nodup) - (membership : (node, foundState) ∈ state.system.nodes) : - Global.nodeState state node = some foundState := by - unfold Global.nodeState - cases found : - state.system.nodes.find? fun entry => entry.1 == node with - | none => - rw [List.find?_eq_none] at found - exact False.elim - (found (node, foundState) membership (by simp)) - | some entry => - have foundMember : entry ∈ state.system.nodes := - List.mem_of_find?_eq_some found - have foundKey : entry.1 = node := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) found) - have same : entry = (node, foundState) := - eq_of_key_eq keysNodup foundMember membership foundKey - simp [same] - -theorem node_property_of_nodeState - {state : State} - {node : Location} - {foundState : NodeState} - {predicate : NodeState -> Prop} - (property : - forall entry, entry ∈ state.system.nodes -> - predicate entry.2) - (found : Global.nodeState state node = some foundState) : - predicate foundState := by - rw [Global.nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - rw [←stateEq] - exact property entry (List.mem_of_find?_eq_some findEq) - -theorem deliver_target_state - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (transition : next config before (.deliver envelope) = some after) : - exists output, - Global.nodeState after envelope.target = some output.state /\ - systemStep config.protocol before.system envelope.target - (eventFor envelope) = some (after.system, output) := by - have afterWellFormed := - next_preserves_well_formed wellFormed transition - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] at afterWellFormed ⊢ - refine ⟨output, ?_, ?_⟩ - · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup - rw [recordEffects_system] - exact systemStep_output_mem systemStep - · simpa using systemStep - -theorem timeout_target_state - {config : Config} - {before after : State} - {target : Location} - (wellFormed : WellFormed config before) - (transition : next config before (.timeout target) = some after) : - exists output, - Global.nodeState after target = some output.state /\ - output.accepted = true /\ - systemStep config.protocol before.system target .timeout = - some (after.system, output) := by - have afterWellFormed := - next_preserves_well_formed wellFormed transition - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, accepted, stateEq⟩ - rw [←stateEq] at afterWellFormed ⊢ - refine ⟨output, ?_, accepted, ?_⟩ - · apply nodeState_eq_of_mem afterWellFormed.nodeKeysNodup - rw [recordEffects_system] - exact systemStep_output_mem systemStep - · simpa using systemStep - -theorem systemStep_output_eq - {config : Protocol.Config} - {global : State} - {after : SystemState} - {target : Location} - {event : Event} - {state : NodeState} - {output : StepOutput} - (found : Global.nodeState global target = some state) - (transition : - systemStep config global.system target event = some (after, output)) : - output = step config state event := by - change - (do - let node <- Global.nodeState global target - let result := step config node event - pure ({ - nodes := replaceNode target result.state global.system.nodes - }, result)) = some (after, output) at transition - rw [found] at transition - simp at transition - exact transition.2.symm - -theorem completed_effect_recorded - {node : Location} - {nodeState : NodeState} - {effects : List Effect} - {state : State} - (completed : .completed ∈ effects) : - node ∈ (recordEffects node nodeState effects state).completed := by - induction effects generalizing state with - | nil => simp at completed - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - rw [List.mem_cons] at completed - rcases completed with rfl | inTail - · apply mem_completed_recordEffects - simp [recordEffect] - · exact ih inTail - -theorem restart_effect_recorded - {node chosen : Location} - {nodeState : NodeState} - {effects : List Effect} - {state : State} - (restart : .restart chosen ∈ effects) : - node ∈ (recordEffects node nodeState effects state).restarts := by - induction effects generalizing state with - | nil => simp at restart - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - rw [List.mem_cons] at restart - rcases restart with rfl | inTail - · apply mem_restarts_recordEffects - simp [recordEffect] - · exact ih inTail - -theorem mem_removeOne_or_eq - [BEq α] - [LawfulBEq α] - {member removed : α} - {values : List α} - (membership : member ∈ values) : - member ∈ removeOne removed values \/ member = removed := by - induction values with - | nil => simp at membership - | cons head tail ih => - rw [List.mem_cons] at membership - rcases membership with rfl | inTail - · by_cases equal : member = removed - · exact Or.inr equal - · exact Or.inl (by simp [removeOne, equal]) - · simp only [removeOne] - split - · exact Or.inl inTail - · rcases ih inTail with still | equal - · exact Or.inl (by simp [still]) - · exact Or.inr equal - structure Fair {config : Config} (execution : Execution config) : Prop where @@ -443,2726 +167,14 @@ structure Fair (HasPhase (execution.states n) node .opening /\ execution.actions n = .timeout node)) -theorem execution_reachable - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) : - forall n, Reachable config (execution.states n) := by - intro n - induction n with - | zero => exact initial - | succ n reachable => - exact Reachable.step reachable (execution.step_succ n) - -theorem execution_active_eq - {config : Config} - (execution : Execution config) : - forall n, (execution.states n).active = (execution.states 0).active := by - intro n - induction n with - | zero => rfl - | succ n activeEq => - exact (next_active_eq (execution.step_succ n)).trans activeEq - -theorem active_at - {config : Config} - (execution : Execution config) - {node : Location} - (active : node ∈ (execution.states 0).active) : - forall n, node ∈ (execution.states n).active := by - intro n - rw [execution_active_eq execution n] - exact active - -theorem recovered_for_configured - {config : Config} - (valid : config.Valid) - {node : Location} - (configured : node ∈ config.protocol.expectedLocations) : - exists txid, recoveredTxID config node = some txid := by - rw [←valid.2.2] at configured - rcases List.mem_map.mp configured with - ⟨entry, membership, keyEq⟩ - rcases entry with ⟨location, txid⟩ - simp at keyEq - subst location - refine ⟨txid, ?_⟩ - apply recoveredTxID_of_mem valid - exact membership - -theorem active_nodeState - {config : Config} - {state : State} - (wellFormed : WellFormed config state) - {node : Location} - (active : node ∈ state.active) : - exists nodeState, - Global.nodeState state node = some nodeState := by - have configured := wellFormed.activeConfigured node active - rw [←wellFormed.nodeKeys] at configured - rcases List.mem_map.mp configured with - ⟨entry, membership, keyEq⟩ - refine ⟨entry.2, ?_⟩ - apply nodeState_eq_of_mem wellFormed.nodeKeysNodup - rcases entry with ⟨location, nodeState⟩ - simp at keyEq - subst location - exact membership - -theorem retryMessages_self_gossip - {config : Config} - {node : Location} - {state : NodeState} - {txid : TxID} - (phase : state.phase = .gossiping) - (configured : node ∈ config.protocol.expectedLocations) - (recovered : recoveredTxID config node = some txid) : - { - source := node - target := node - payload := Payload.gossip txid - sourceState := state - } ∈ retryMessages config node state := by - rw [retryMessages, List.mem_filterMap] - refine ⟨.sendGossip node, ?_, ?_⟩ - · simpa [step, phase] using configured - · simp [messageForEffect, recovered] - -theorem retryMessages_vote - {config : Config} - {node target : Location} - {state : NodeState} - (phase : state.phase = .voting) - (chosen : state.chosen = some target) : - { - source := node - target - payload := Payload.vote - sourceState := state - } ∈ retryMessages config node state := by - rw [retryMessages, List.mem_filterMap] - refine ⟨.sendVote target, ?_, rfl⟩ - simp [step, phase, chosen] - -theorem retry_iamopen_state - {config : Config} - {envelope : Envelope} - (valid : envelope.Valid config) - (announcement : envelope.payload = .iAmOpen) : - envelope.sourceState.phase = .opening := by - rcases valid_envelope_effect valid with - ⟨effect, member, created⟩ - cases effect with - | sendGossip target => - cases found : recoveredTxID config envelope.source with - | none => simp [messageForEffect, found] at created - | some txid => - simp [messageForEffect, found] at created - rw [←created] at announcement - contradiction - | sendVote target => - simp [messageForEffect] at created - rw [←created] at announcement - contradiction - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] at announcement ⊢ - cases phase : envelope.sourceState.phase - case opening => rfl - case voting => - cases chosen : envelope.sourceState.chosen <;> - simp [step, phase, chosen] at member - all_goals simp [step, phase] at member - | opening kind => simp [messageForEffect] at created - | restart chosen => simp [messageForEffect] at created - | completed => simp [messageForEffect] at created - | rejected reason => simp [messageForEffect] at created - def acceptedIAmOpenSource : Event -> Option Location | .receiveIAmOpen source .accepted => some source | _ => none -theorem step_joining_origin - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (joining : (step config state event).state.phase = .joining) : - state.phase = .joining \/ - exists source, acceptedIAmOpenSource event = some source := by - cases event - all_goals try cases_type Validation - all_goals - simp [acceptedIAmOpenSource, step, rejected, advance, - advanceTimeoutLane] at joining ⊢ - all_goals - repeat first | split at joining | split | simp_all | aesop - -theorem step_open_origin - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (opened : (step config state event).state.phase = .open) : - state.phase = .open \/ - .completed ∈ (step config state event).effects := by - cases event - all_goals try cases_type Validation - all_goals - simp [step, rejected, advance, advanceTimeoutLane, validTimeout] - at opened ⊢ - all_goals - repeat first | split at opened | split | simp_all | aesop - -theorem iamopen_delivery_outcome - (config : Protocol.Config) - (state : NodeState) - (source : Location) : - let output := step config state (.receiveIAmOpen source .accepted) - output.state.phase = .opening \/ - output.state.phase = .open \/ - exists chosen, .restart chosen ∈ output.effects := by - cases phase : state.phase <;> - simp [step, phase, rejected, advance, advanceTimeoutLane] - -theorem iamopen_open_predecessor - (config : Protocol.Config) - (state : NodeState) - (source : Location) - (opened : - (step config state (.receiveIAmOpen source .accepted)).state.phase = - .open) : - state.phase = .open := by - cases phase : state.phase <;> - simp [step, phase, rejected, advance, advanceTimeoutLane] at opened - rfl - -theorem eventFor_iamopen_source - {envelope : Envelope} - {source : Location} - (accepted : - acceptedIAmOpenSource (eventFor envelope) = some source) : - envelope.payload = .iAmOpen /\ - envelope.source = source := by - cases payload : envelope.payload <;> - simp_all [eventFor, acceptedIAmOpenSource] - -theorem retry_gossip_enabled - {config : Config} - {state : State} - {node : Location} - (valid : config.Valid) - (wellFormed : WellFormed config state) - (active : node ∈ state.active) - (phase : HasPhase state node .gossiping) : - Enabled config state (.retry node) := by - rcases phase with ⟨nodeState, found, gossiping⟩ - have configured := wellFormed.activeConfigured node active - rcases recovered_for_configured valid configured with - ⟨txid, recovered⟩ - have message := - retryMessages_self_gossip gossiping configured recovered - have messagesNonempty : - retryMessages config node nodeState ≠ [] := by - intro empty - rw [empty] at message - simp at message - refine ⟨{ - state with - network := state.network ++ retryMessages config node nodeState - sent := state.sent ++ retryMessages config node nodeState - }, ?_⟩ - simp [next, active, found, messagesNonempty] - -theorem retry_voting_enabled - {config : Config} - {state : State} - {node target : Location} - {nodeState : NodeState} - (active : node ∈ state.active) - (found : Global.nodeState state node = some nodeState) - (phase : nodeState.phase = .voting) - (chosen : nodeState.chosen = some target) : - Enabled config state (.retry node) := by - have message := retryMessages_vote (config := config) - (node := node) phase chosen - have messagesNonempty : - retryMessages config node nodeState ≠ [] := by - intro empty - rw [empty] at message - simp at message - refine ⟨{ - state with - network := state.network ++ retryMessages config node nodeState - sent := state.sent ++ retryMessages config node nodeState - }, ?_⟩ - simp [next, active, found, messagesNonempty] - -theorem delivery_enabled - {config : Config} - {state : State} - {envelope : Envelope} - (wellFormed : WellFormed config state) - (network : envelope ∈ state.network) - (targetActive : envelope.target ∈ state.active) : - Enabled config state (.deliver envelope) := by - rcases active_nodeState wellFormed targetActive with - ⟨targetState, found⟩ - let output := step config.protocol targetState (eventFor envelope) - let system : SystemState := { - nodes := replaceNode envelope.target output.state state.system.nodes - } - let delivered : State := { - state with - system - network := removeOne envelope state.network - } - have stepResult : - systemStep config.protocol state.system envelope.target - (eventFor envelope) = some (system, output) := by - change - (do - let node <- Global.nodeState state envelope.target - let result := step config.protocol node (eventFor envelope) - pure ({ - nodes := - replaceNode envelope.target result.state state.system.nodes - }, result)) = some (system, output) - rw [found] - rfl - refine - ⟨recordEffects envelope.target output.state output.effects delivered, ?_⟩ - simp [next, network, targetActive, stepResult, output, system, - delivered] - -theorem timeout_enabled_of_accepted - {config : Config} - {state : State} - {node : Location} - {nodeState : NodeState} - (active : node ∈ state.active) - (found : Global.nodeState state node = some nodeState) - (accepted : (step config.protocol nodeState .timeout).accepted = true) : - Enabled config state (.timeout node) := by - let output := step config.protocol nodeState .timeout - let system : SystemState := { - nodes := replaceNode node output.state state.system.nodes - } - have stepResult : - systemStep config.protocol state.system node .timeout = - some (system, output) := by - change - (do - let current <- Global.nodeState state node - let result := step config.protocol current .timeout - pure ({ - nodes := replaceNode node result.state state.system.nodes - }, result)) = some (system, output) - rw [found] - rfl - refine - ⟨recordEffects node output.state output.effects - { state with system }, ?_⟩ - simp [next, active, stepResult, accepted, output, system] - -theorem retry_gossip_enqueued - {config : Config} - {before after : State} - {node : Location} - (valid : config.Valid) - (wellFormed : WellFormed config before) - (phase : HasPhase before node .gossiping) - (transition : next config before (.retry node) = some after) : - exists envelope, - envelope ∈ after.network /\ - envelope.source = node /\ - envelope.target = node /\ - exists txid, envelope.payload = .gossip txid := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨active, sourceState, found, _, stateEq⟩ - rcases phase with ⟨phaseState, foundPhase, gossiping⟩ - have configured := - wellFormed.activeConfigured node active - rcases recovered_for_configured valid configured with - ⟨txid, recovered⟩ - rw [found] at foundPhase - injection foundPhase with stateEq' - subst phaseState - let envelope : Envelope := { - source := node - target := node - payload := .gossip txid - sourceState - } - have message : envelope ∈ retryMessages config node sourceState := - retryMessages_self_gossip gossiping configured recovered - rw [←stateEq] - exact - ⟨envelope, List.mem_append_right _ message, rfl, rfl, txid, rfl⟩ - -theorem retry_vote_enqueued - {config : Config} - {before after : State} - {node target : Location} - {nodeState : NodeState} - (found : Global.nodeState before node = some nodeState) - (phase : nodeState.phase = .voting) - (chosen : nodeState.chosen = some target) - (transition : next config before (.retry node) = some after) : - exists envelope, - envelope ∈ after.network /\ - envelope.source = node /\ - envelope.target = target /\ - envelope.payload = .vote := by - have message := retryMessages_vote (config := config) - (node := node) phase chosen - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, actualState, actualFound, _, stateEq⟩ - rw [found] at actualFound - injection actualFound with actualEq - subst actualState - let envelope : Envelope := { - source := node - target - payload := .vote - sourceState := nodeState - } - rw [←stateEq] - exact - ⟨envelope, List.mem_append_right _ message, rfl, rfl, rfl⟩ - -theorem insertGossip_nonempty - (source : Location) - (txid : TxID) - (gossips : List (Prod Location TxID)) : - insertGossip source txid gossips ≠ [] := by - unfold insertGossip - split - · rename_i present - intro empty - subst gossips - simp at present - · intro empty - have lengths := - (List.mergeSort_perm ((source, txid) :: gossips) - (fun left right => left.1 <= right.1)).length_eq - rw [empty] at lengths - simp at lengths - -theorem maximumGossip_some - {gossips : List (Prod Location TxID)} - (nonempty : gossips ≠ []) : - exists selected, maximumGossip gossips = some selected := by - cases gossips with - | nil => contradiction - | cons head tail => - exact ⟨tail.foldl selectMaximum head, rfl⟩ - -theorem gossip_receive_progress - (config : Protocol.Config) - (state : NodeState) - (source : Location) - (txid : TxID) - (valid : LaneValid state) - (phase : state.phase = .gossiping) : - let output := - step config state (.receiveGossip source txid .accepted) - output.state.phase ≠ .gossiping \/ - output.state.gossips ≠ [] := by - have chosen := valid.2.2.2 phase - have nonempty := insertGossip_nonempty source txid state.gossips - obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty - simp [step, phase, chosen, rejected, advance, advanceTimeoutLane, - validTimeout] - repeat first | split | simp_all - -theorem gossip_timeout_progress - (config : Protocol.Config) - (state : NodeState) - (valid : LaneValid state) - (phase : state.phase = .gossiping) - (accepted : (step config state .timeout).accepted = true) : - (step config state .timeout).state.phase = .voting := by - have lane := valid.1 phase - simp [step, phase, lane, rejected, advance, advanceTimeoutLane, - validTimeout] at accepted ⊢ - repeat first | split at accepted | split | simp_all - -theorem gossip_timeout_enabled_local - (config : Protocol.Config) - (state : NodeState) - (valid : LaneValid state) - (phase : state.phase = .gossiping) - (nonempty : state.gossips ≠ []) : - (step config state .timeout).accepted = true := by - have lane := valid.1 phase - obtain ⟨selected, maximum⟩ := maximumGossip_some nonempty - simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, - maximum] - -theorem gossip_timeout_enabled - {config : Config} - {state : State} - {node : Location} - (active : node ∈ state.active) - (lanes : NodeLanesValid state) - (phase : HasPhase state node .gossiping) - (gossip : HasGossip state node) : - Enabled config state (.timeout node) := by - rcases phase with ⟨phaseState, foundPhase, gossiping⟩ - rcases gossip with ⟨gossipState, foundGossip, nonempty⟩ - rw [foundPhase] at foundGossip - injection foundGossip with stateEq - subst gossipState - have lane := node_property_of_nodeState lanes foundPhase - apply timeout_enabled_of_accepted active foundPhase - exact gossip_timeout_enabled_local config.protocol phaseState lane - gossiping nonempty - def openingDistance : Phase -> Nat | .gossiping => 3 | .voting => 2 | .opening => 1 | .joining | .open => 0 -theorem opening_timeout_local - (config : Protocol.Config) - (state : NodeState) - (valid : LaneValid state) - (phase : state.phase = .opening) : - let output := step config state .timeout - (output.effects = [.completed] /\ output.state.phase = .open) \/ - (output.state.phase = .opening /\ - openingDistance output.state.timeoutState < - openingDistance state.timeoutState) := by - rcases valid.2.2.1 phase with lane | lane | lane - · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, - advanceTimeoutState, openingDistance] - · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, - advanceTimeoutState, openingDistance] - · simp [step, phase, lane, advance, validTimeout, advanceTimeoutLane, - advanceTimeoutState, openingDistance] - -theorem opening_step_distance_le - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (valid : LaneValid state) - (phase : state.phase = .opening) - (after : (step config state event).state.phase = .opening) : - openingDistance (step config state event).state.timeoutState <= - openingDistance state.timeoutState := by - cases event with - | receiveGossip source txid validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - repeat first | split | simp_all - | receiveVote source validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - | receiveIAmOpen source validation => - cases validation <;> simp [step, phase, rejected] - | timeout => - rcases opening_timeout_local config state valid phase with - done | progress - · rw [done.2] at after - contradiction - · exact Nat.le_of_lt progress.2 - | retry => simp [step] - -theorem opening_step_or_completed - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (phase : state.phase = .opening) : - (step config state event).state.phase = .opening \/ - ((step config state event).state.phase = .open /\ - .completed ∈ (step config state event).effects) := by - cases event with - | receiveGossip source txid validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - repeat first | split | simp_all - | receiveVote source validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - | receiveIAmOpen source validation => - cases validation <;> simp [step, phase, rejected] - | timeout => - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - split <;> simp_all - | retry => simp [step, phase] - -theorem opening_non_timeout - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (phase : state.phase = .opening) - (notTimeout : event ≠ .timeout) : - (step config state event).state.phase = .opening /\ - (step config state event).state.timeoutState = - state.timeoutState := by - cases event with - | receiveGossip source txid validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - repeat first | split | simp_all - | receiveVote source validation => - cases validation <;> - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - | receiveIAmOpen source validation => - cases validation <;> simp [step, phase, rejected] - | timeout => contradiction - | retry => exact ⟨phase, rfl⟩ - -theorem opening_timeout_enabled - {config : Config} - {state : State} - {node : Location} - (active : node ∈ state.active) - (phase : HasPhase state node .opening) : - Enabled config state (.timeout node) := by - rcases phase with ⟨nodeState, found, opening⟩ - apply timeout_enabled_of_accepted active found - simp [step, opening, advance, rejected] - repeat first | split | simp_all - -theorem timeout_opening_step - {config : Config} - {before after : State} - {node : Location} - {beforeState : NodeState} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (foundBefore : - Global.nodeState before node = some beforeState) - (opening : beforeState.phase = .opening) - (transition : next config before (.timeout node) = some after) : - CompletedOpen after node \/ - (exists nextState : NodeState, - Global.nodeState after node = some nextState /\ - nextState.phase = .opening /\ - openingDistance nextState.timeoutState < - openingDistance beforeState.timeoutState) := by - have lane : LaneValid beforeState := by - apply node_property_of_nodeState (predicate := LaneValid) - · exact lanes - · exact foundBefore - have timeoutResult : - ((step config.protocol beforeState .timeout).effects = - [.completed] /\ - (step config.protocol beforeState .timeout).state.phase = .open) \/ - ((step config.protocol beforeState .timeout).state.phase = - .opening /\ - openingDistance - (step config.protocol beforeState .timeout).state.timeoutState < - openingDistance beforeState.timeoutState) := - opening_timeout_local config.protocol beforeState lane opening - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - have outputEq := systemStep_output_eq foundBefore systemStep - rw [←outputEq] at timeoutResult - rw [←stateEq] - rcases timeoutResult with completed | progress - · exact Or.inl (by - rcases completed with ⟨effects, _⟩ - rw [effects] - simp [CompletedOpen, recordEffects, recordEffect]) - · exact Or.inr - ⟨output.state, - (by - apply nodeState_eq_of_mem - · rw [recordEffects_system, - systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · rw [recordEffects_system] - exact systemStep_output_mem systemStep), - progress.1, - by simpa using progress.2⟩ - -theorem next_opening_progress - {config : Config} - {before after : State} - {node : Location} - {beforeState : NodeState} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (foundBefore : - Global.nodeState before node = some beforeState) - (opening : beforeState.phase = .opening) - (transition : next config before action = some after) : - CompletedOpen after node \/ - (exists afterState : NodeState, - Global.nodeState after node = some afterState /\ - afterState.phase = .opening /\ - openingDistance afterState.timeoutState <= - openingDistance beforeState.timeoutState) := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - exact Or.inr - ⟨beforeState, foundBefore, opening, Nat.le_refl _⟩ - | deliver envelope => - by_cases target : node = envelope.target - · subst node - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - have preserved := - opening_non_timeout config.protocol beforeState - (eventFor envelope) opening - (by - cases payloadEq : envelope.payload <;> - simp [eventFor, payloadEq]) - rw [←outputEq] at preserved - exact Or.inr - ⟨output.state, foundAfter, preserved.1, - by rw [preserved.2]⟩ - · have unchanged := deliver_other_node_eq target transition - rw [foundBefore] at unchanged - exact Or.inr - ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ - | timeout target => - by_cases same : node = target - · subst node - rcases timeout_opening_step wellFormed lanes foundBefore - opening transition with - completed | ⟨nextState, foundAfter, nextOpening, distance⟩ - · exact Or.inl completed - · exact Or.inr - ⟨nextState, foundAfter, nextOpening, - Nat.le_of_lt distance⟩ - · have unchanged := timeout_other_node_eq same transition - rw [foundBefore] at unchanged - exact Or.inr - ⟨beforeState, by simp [unchanged], opening, Nat.le_refl _⟩ - -theorem insertVote_nonempty - (source : Location) - (votes : List Location) : - insertVote source votes ≠ [] := by - unfold insertVote - split - · rename_i present - intro empty - subst votes - simp at present - · intro empty - have lengths := - (List.mergeSort_perm (source :: votes) - (fun left right => left <= right)).length_eq - rw [empty] at lengths - simp at lengths - -theorem step_preserves_nonempty_votes - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (nonempty : state.votes ≠ []) : - (step config state event).state.votes ≠ [] := by - rcases step_votes_shape config state event with - unchanged | ⟨source, _, changed⟩ - · rw [unchanged] - exact nonempty - · rw [changed] - exact insertVote_nonempty source state.votes - -theorem next_preserves_hasVote - {config : Config} - {before after : State} - {action : Action} - {node : Location} - (wellFormed : WellFormed config before) - (vote : HasVote before node) - (transition : next config before action = some after) : - HasVote after node := by - rcases vote with ⟨beforeState, foundBefore, nonempty⟩ - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - exact ⟨beforeState, foundBefore, nonempty⟩ - | deliver envelope => - by_cases target : node = envelope.target - · subst node - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - exact - ⟨output.state, foundAfter, - by - rw [outputEq] - exact step_preserves_nonempty_votes - config.protocol beforeState (eventFor envelope) nonempty⟩ - · have unchanged := deliver_other_node_eq target transition - rw [foundBefore] at unchanged - exact ⟨beforeState, by simp [unchanged], nonempty⟩ - | timeout target => - by_cases same : node = target - · subst node - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, _, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - exact - ⟨output.state, foundAfter, - by - rw [outputEq] - exact step_preserves_nonempty_votes - config.protocol beforeState .timeout nonempty⟩ - · have unchanged := timeout_other_node_eq same transition - rw [foundBefore] at unchanged - exact ⟨beforeState, by simp [unchanged], nonempty⟩ - -theorem hasVote_mono - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (vote : HasVote (execution.states start) node) : - HasVote (execution.states finish) node := by - induction finish, order using Nat.le_induction with - | base => exact vote - | succ finish order vote => - exact next_preserves_hasVote - (reachable_well_formed - (execution_reachable execution initial finish)) - vote (execution.step_succ finish) - -theorem next_preserves_advanced_lane - {config : Config} - {before after : State} - {action : Action} - {node : Location} - (wellFormed : WellFormed config before) - (advanced : LaneAdvanced before node) - (transition : next config before action = some after) : - LaneAdvanced after node := by - rcases advanced with ⟨beforeState, foundBefore, lane⟩ - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - exact ⟨beforeState, foundBefore, lane⟩ - | deliver envelope => - by_cases target : node = envelope.target - · subst node - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - exact - ⟨output.state, foundAfter, - by - rw [outputEq] - exact step_preserves_advanced_lane - config.protocol beforeState (eventFor envelope) lane⟩ - · have unchanged := deliver_other_node_eq target transition - rw [foundBefore] at unchanged - exact ⟨beforeState, by simp [unchanged], lane⟩ - | timeout target => - by_cases same : node = target - · subst node - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, _, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - exact - ⟨output.state, foundAfter, - by - rw [outputEq] - exact step_preserves_advanced_lane - config.protocol beforeState .timeout lane⟩ - · have unchanged := timeout_other_node_eq same transition - rw [foundBefore] at unchanged - exact ⟨beforeState, by simp [unchanged], lane⟩ - -theorem advanced_lane_mono - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (advanced : LaneAdvanced (execution.states start) node) : - LaneAdvanced (execution.states finish) node := by - induction finish, order using Nat.le_induction with - | base => exact advanced - | succ finish order advanced => - exact next_preserves_advanced_lane - (reachable_well_formed - (execution_reachable execution initial finish)) - advanced (execution.step_succ finish) - -theorem opening_progress_between - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - {start finish : Nat} - {node : Location} - {startState : NodeState} - (order : start <= finish) - (foundStart : - Global.nodeState (execution.states start) node = some startState) - (openingStart : startState.phase = .opening) - (notCompleted : - Not (CompletedOpen (execution.states finish) node)) : - exists finishState : NodeState, - Global.nodeState (execution.states finish) node = some finishState /\ - finishState.phase = .opening /\ - openingDistance finishState.timeoutState <= - openingDistance startState.timeoutState := by - induction finish, order using Nat.le_induction with - | base => - exact - ⟨startState, foundStart, openingStart, Nat.le_refl _⟩ - | succ finish order ih => - have notCompletedBefore : - Not (CompletedOpen (execution.states finish) node) := by - intro completed - exact notCompleted - (next_completed_monotonic - (execution.step_succ finish) node completed) - rcases ih notCompletedBefore with - ⟨beforeState, foundBefore, openingBefore, distanceBefore⟩ - rcases next_opening_progress - (reachable_well_formed - (execution_reachable execution initial finish)) - (reachable_lanes_valid - (execution_reachable execution initial finish)) - foundBefore openingBefore (execution.step_succ finish) with - completed | - ⟨afterState, foundAfter, openingAfter, distanceAfter⟩ - · contradiction - · exact - ⟨afterState, foundAfter, openingAfter, - Nat.le_trans distanceAfter distanceBefore⟩ - -theorem deliver_gossip_progress - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (payload : exists txid, envelope.payload = .gossip txid) - (phase : HasPhase before envelope.target .gossiping) - (transition : next config before (.deliver envelope) = some after) : - Not (HasPhase after envelope.target .gossiping) \/ - HasGossip after envelope.target := by - rcases phase with ⟨beforeState, foundBefore, gossiping⟩ - rcases payload with ⟨txid, payload⟩ - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - have lane := - node_property_of_nodeState lanes foundBefore - simp [eventFor, payload] at outputEq - have progress := - gossip_receive_progress config.protocol beforeState - envelope.source txid lane gossiping - rw [←outputEq] at progress - rcases progress with left | right - · exact Or.inl (by - intro stillGossiping - rcases stillGossiping with ⟨state, found, phase⟩ - rw [foundAfter] at found - injection found with stateEq - subst state - exact left phase) - · exact Or.inr ⟨output.state, foundAfter, right⟩ - -theorem timeout_gossip_progress - {config : Config} - {before after : State} - {node : Location} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (phase : HasPhase before node .gossiping) - (transition : next config before (.timeout node) = some after) : - HasPhase after node .voting := by - rcases phase with ⟨beforeState, foundBefore, gossiping⟩ - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, accepted, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - have lane := - node_property_of_nodeState lanes foundBefore - have voting := - gossip_timeout_progress config.protocol beforeState lane - gossiping (by simpa [outputEq] using accepted) - exact - ⟨output.state, foundAfter, by simpa [outputEq] using voting⟩ - -theorem vote_receive_progress - (config : Protocol.Config) - (state : NodeState) - (source : Location) - (phase : state.phase = .voting) : - let output := step config state (.receiveVote source .accepted) - output.state.phase ≠ .voting \/ output.state.votes ≠ [] := by - have nonempty := insertVote_nonempty source state.votes - simp [step, phase, rejected, advance, validTimeout, - advanceTimeoutLane] - repeat first | split | simp_all - -theorem voting_timeout_local - (config : Protocol.Config) - (state : NodeState) - (valid : LaneValid state) - (phase : state.phase = .voting) - (nonempty : state.votes ≠ []) : - let output := step config state .timeout - output.state.phase = .opening \/ - (output.state.phase = .voting /\ - output.state.timeoutState = .voting) := by - rcases valid.2.1 phase with lane | lane - · simp [step, phase, lane, rejected, advance, validTimeout, - advanceTimeoutLane, advanceTimeoutState] - repeat first | split | simp_all - · simp [step, phase, lane, nonempty, rejected, advance, validTimeout, - advanceTimeoutLane, advanceTimeoutState] - -theorem aligned_voting_timeout_opens - (config : Protocol.Config) - (state : NodeState) - (phase : state.phase = .voting) - (lane : state.timeoutState = .voting) - (nonempty : state.votes ≠ []) : - (step config state .timeout).state.phase = .opening := by - simp [step, phase, lane, nonempty, rejected, advance, validTimeout, - advanceTimeoutLane] - -theorem deliver_vote_progress - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (payload : envelope.payload = .vote) - (phase : HasPhase before envelope.target .voting) - (transition : next config before (.deliver envelope) = some after) : - Not (HasPhase after envelope.target .voting) \/ - HasVote after envelope.target := by - rcases phase with ⟨beforeState, foundBefore, voting⟩ - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - have outputEq := - systemStep_output_eq foundBefore systemStep - simp [eventFor, payload] at outputEq - have progress := - vote_receive_progress config.protocol beforeState - envelope.source voting - rw [←outputEq] at progress - rcases progress with left | right - · exact Or.inl (by - intro stillVoting - rcases stillVoting with ⟨state, found, phase⟩ - rw [foundAfter] at found - injection found with stateEq - subst state - exact left phase) - · exact Or.inr ⟨output.state, foundAfter, right⟩ - -theorem deliver_iamopen_resolves - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (openCompleted : OpenCompleted before) - (payload : envelope.payload = .iAmOpen) - (transition : next config before (.deliver envelope) = some after) : - Terminal after envelope.target \/ - HasPhase after envelope.target .opening := by - have details := transition - simp [next, Option.bind_eq_some_iff] at details - rcases details with - ⟨_, targetActive, system, output, systemStep, stateEq⟩ - rcases active_nodeState wellFormed targetActive with - ⟨beforeState, foundBefore⟩ - have outputEq := systemStep_output_eq foundBefore systemStep - simp [eventFor, payload] at outputEq - have outcome := - iamopen_delivery_outcome config.protocol beforeState envelope.source - rw [←outputEq] at outcome - rw [←stateEq] - rcases outcome with opening | opened | ⟨chosen, restarted⟩ - · exact Or.inr - ⟨output.state, - by - apply nodeState_eq_of_mem - · rw [recordEffects_system, - systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · rw [recordEffects_system] - exact systemStep_output_mem systemStep, - opening⟩ - · have beforeOpen := - iamopen_open_predecessor config.protocol beforeState - envelope.source (by simpa [outputEq] using opened) - have completedBefore : CompletedOpen before envelope.target := by - rw [Global.nodeState, Option.map_eq_some_iff] at foundBefore - rcases foundBefore with ⟨entry, findEq, stateEq⟩ - have keyEq : entry.1 = envelope.target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == envelope.target) findEq) - rw [←keyEq] - apply openCompleted entry (List.mem_of_find?_eq_some findEq) - simpa [stateEq] using beforeOpen - exact Or.inl (Or.inr - (mem_completed_recordEffects completedBefore)) - · exact Or.inl (Or.inl - (restart_effect_recorded restarted)) - -theorem voting_timeout_enabled - {config : Config} - {state : State} - {node : Location} - (active : node ∈ state.active) - (phase : HasPhase state node .voting) : - Enabled config state (.timeout node) := by - rcases phase with ⟨nodeState, found, voting⟩ - apply timeout_enabled_of_accepted active found - simp [step, voting, advance, rejected] - repeat first | split | simp_all - -theorem timeout_voting_step - {config : Config} - {before after : State} - {node : Location} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (phase : HasPhase before node .voting) - (vote : HasVote before node) - (transition : next config before (.timeout node) = some after) : - HasPhase after node .opening \/ - (exists nextState : NodeState, - Global.nodeState after node = some nextState /\ - nextState.phase = .voting /\ - nextState.timeoutState = .voting /\ - nextState.votes ≠ []) := by - rcases phase with ⟨beforeState, foundBefore, voting⟩ - rcases vote with ⟨voteState, foundVote, nonempty⟩ - rw [foundBefore] at foundVote - injection foundVote with stateEq - subst voteState - have lane : LaneValid beforeState := by - apply node_property_of_nodeState (predicate := LaneValid) - · exact lanes - · exact foundBefore - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, _, systemStep⟩ - have outputEq := systemStep_output_eq foundBefore systemStep - have progress := - voting_timeout_local config.protocol beforeState lane voting nonempty - rw [←outputEq] at progress - rcases progress with opening | waiting - · exact Or.inl ⟨output.state, foundAfter, opening⟩ - · exact Or.inr - ⟨output.state, foundAfter, waiting.1, waiting.2, - by - rw [outputEq] - exact step_preserves_nonempty_votes - config.protocol beforeState .timeout nonempty⟩ - -theorem aligned_timeout_voting_opens - {config : Config} - {before after : State} - {node : Location} - {nodeState : NodeState} - (wellFormed : WellFormed config before) - (found : Global.nodeState before node = some nodeState) - (phase : nodeState.phase = .voting) - (lane : nodeState.timeoutState = .voting) - (nonempty : nodeState.votes ≠ []) - (transition : next config before (.timeout node) = some after) : - HasPhase after node .opening := by - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, _, systemStep⟩ - have outputEq := systemStep_output_eq found systemStep - exact - ⟨output.state, foundAfter, - by - rw [outputEq] - exact aligned_voting_timeout_opens config.protocol nodeState - phase lane nonempty⟩ - -theorem fair_gossip_progress - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - {start : Nat} - {node : Location} - (active : node ∈ (execution.states start).active) - (phase : HasPhase (execution.states start) node .gossiping) : - EventuallyFrom start (fun n => - Not (HasPhase (execution.states n) node .gossiping)) := by - have reachable (n : Nat) := - execution_reachable execution initial n - have configValid := reachable_config_valid (reachable start) - have retryEnabled := - retry_gossip_enabled configValid - (reachable_well_formed (reachable start)) active phase - rcases fair.retry start node .gossiping active phase - (Or.inl rfl) retryEnabled with - ⟨retryAt, startRetry, leftGossip | retryAction⟩ - · exact ⟨retryAt, startRetry, leftGossip⟩ - · by_cases retryPhase : - HasPhase (execution.states retryAt) node .gossiping - · have retryStep : - next config (execution.states retryAt) (.retry node) = - some (execution.states (retryAt + 1)) := by - simpa [retryAction] using execution.step_succ retryAt - rcases retry_gossip_enqueued configValid - (reachable_well_formed (reachable retryAt)) - retryPhase retryStep with - ⟨envelope, pending, sourceEq, targetEq, txid, payload⟩ - rcases fair.delivery (retryAt + 1) envelope pending with - ⟨deliverAt, retryDeliver, deliverAction⟩ - by_cases deliverPhase : - HasPhase (execution.states deliverAt) node .gossiping - · have deliverStep : - next config (execution.states deliverAt) - (.deliver envelope) = - some (execution.states (deliverAt + 1)) := by - simpa [deliverAction] using execution.step_succ deliverAt - have delivered := - deliver_gossip_progress - (reachable_well_formed (reachable deliverAt)) - (reachable_lanes_valid (reachable deliverAt)) - ⟨txid, payload⟩ - (by simpa [targetEq] using deliverPhase) - deliverStep - rcases delivered with leftAfter | hasGossip - · exact - ⟨deliverAt + 1, by omega, by simpa [targetEq] using leftAfter⟩ - · by_cases afterPhase : - HasPhase (execution.states (deliverAt + 1)) node .gossiping - · have timeoutEnabled := - gossip_timeout_enabled - (config := config) - (by - rw [execution_active_eq execution (deliverAt + 1)] - rw [execution_active_eq execution start] at active - exact active) - (reachable_lanes_valid (reachable (deliverAt + 1))) - afterPhase - (by simpa [targetEq] using hasGossip) - rcases fair.timeout (deliverAt + 1) node .gossiping - (by - rw [execution_active_eq execution (deliverAt + 1)] - rw [execution_active_eq execution start] at active - exact active) - afterPhase (Or.inl rfl) timeoutEnabled with - ⟨timeoutAt, deliverTimeout, leftBeforeTimeout | timeoutAction⟩ - · exact ⟨timeoutAt, by omega, leftBeforeTimeout⟩ - · by_cases timeoutPhase : - HasPhase (execution.states timeoutAt) node .gossiping - · have timeoutStep : - next config (execution.states timeoutAt) - (.timeout node) = - some (execution.states (timeoutAt + 1)) := by - simpa [timeoutAction] using - execution.step_succ timeoutAt - have voting := - timeout_gossip_progress - (reachable_well_formed (reachable timeoutAt)) - (reachable_lanes_valid (reachable timeoutAt)) - timeoutPhase timeoutStep - refine ⟨timeoutAt + 1, by omega, ?_⟩ - intro impossible - have phases := hasPhase_unique voting impossible - contradiction - · exact ⟨timeoutAt, by omega, timeoutPhase⟩ - · exact ⟨deliverAt + 1, by omega, afterPhase⟩ - · exact ⟨deliverAt, by omega, deliverPhase⟩ - · exact ⟨retryAt, startRetry, retryPhase⟩ - -theorem next_gossiping_predecessor - {config : Config} - {before after : State} - {action : Action} - {node : Location} - (wellFormed : WellFormed config before) - (transition : next config before action = some after) - (afterGossip : HasPhase after node .gossiping) : - HasPhase before node .gossiping := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] at afterGossip - exact afterGossip - | deliver envelope => - by_cases target : node = envelope.target - · subst node - have details := transition - simp [next, Option.bind_eq_some_iff] at details - have targetActive := details.2.1 - rcases active_nodeState wellFormed targetActive with - ⟨beforeState, foundBefore⟩ - rcases deliver_target_state wellFormed transition with - ⟨output, foundAfter, systemStep⟩ - rcases afterGossip with ⟨afterState, found, phase⟩ - rw [foundAfter] at found - injection found with stateEq - subst afterState - have outputEq := - systemStep_output_eq foundBefore systemStep - have beforePhase : beforeState.phase = .gossiping := by - by_contra notGossip - have notAfter := - step_preserves_non_gossiping config.protocol beforeState - (eventFor envelope) notGossip - rw [←outputEq] at notAfter - exact notAfter phase - exact ⟨beforeState, foundBefore, beforePhase⟩ - · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ - have unchanged := - deliver_other_node_eq target transition - rw [foundAfter] at unchanged - cases foundBefore : - Global.nodeState before node with - | none => simp [foundBefore] at unchanged - | some beforeState => - rw [foundBefore] at unchanged - injection unchanged with stateEq - subst beforeState - exact ⟨afterState, foundBefore, phase⟩ - | timeout target => - by_cases same : node = target - · subst node - have details := transition - simp [next, Option.bind_eq_some_iff] at details - have targetActive := details.1 - rcases active_nodeState wellFormed targetActive with - ⟨beforeState, foundBefore⟩ - rcases timeout_target_state wellFormed transition with - ⟨output, foundAfter, _, systemStep⟩ - rcases afterGossip with ⟨afterState, found, phase⟩ - rw [foundAfter] at found - injection found with stateEq - subst afterState - have outputEq := - systemStep_output_eq foundBefore systemStep - have beforePhase : beforeState.phase = .gossiping := by - by_contra notGossip - have notAfter := - step_preserves_non_gossiping config.protocol beforeState - .timeout notGossip - rw [←outputEq] at notAfter - exact notAfter phase - exact ⟨beforeState, foundBefore, beforePhase⟩ - · rcases afterGossip with ⟨afterState, foundAfter, phase⟩ - have unchanged := - timeout_other_node_eq same transition - rw [foundAfter] at unchanged - cases foundBefore : - Global.nodeState before node with - | none => simp [foundBefore] at unchanged - | some beforeState => - rw [foundBefore] at unchanged - injection unchanged with stateEq - subst beforeState - exact ⟨afterState, foundBefore, phase⟩ - -theorem not_gossiping_mono - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (notGossip : - Not (HasPhase (execution.states start) node .gossiping)) : - Not (HasPhase (execution.states finish) node .gossiping) := by - induction finish, order using Nat.le_induction with - | base => exact notGossip - | succ finish order notGossip => - intro gossip - exact notGossip - (next_gossiping_predecessor - (reachable_well_formed - (execution_reachable execution initial finish)) - (execution.step_succ finish) gossip) - -theorem eventually_list - {predicate : Nat -> Location -> Prop} - {start : Nat} - (nodes : List Location) - (eventual : - forall node, node ∈ nodes -> - EventuallyFrom start (fun n => predicate n node)) - (monotonic : - forall node first second, - first <= second -> - predicate first node -> - predicate second node) : - EventuallyFrom start (fun n => - forall node, node ∈ nodes -> predicate n node) := by - revert eventual - induction nodes with - | nil => - intro eventual - exact ⟨start, Nat.le_refl start, by simp⟩ - | cons head tail ih => - intro eventual - rcases eventual head (by simp) with - ⟨headAt, startHead, headHolds⟩ - rcases ih - (fun node membership => eventual node (by simp [membership])) with - ⟨tailAt, startTail, tailHolds⟩ - refine - ⟨max headAt tailAt, by omega, ?_⟩ - intro node membership - rw [List.mem_cons] at membership - rcases membership with rfl | inTail - · exact monotonic _ headAt (max headAt tailAt) - (Nat.le_max_left _ _) headHolds - · exact monotonic node tailAt (max headAt tailAt) - (Nat.le_max_right _ _) (tailHolds node inTail) - -theorem fair_all_leave_gossip - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (start : Nat) : - EventuallyFrom start (fun n => - forall node, node ∈ (execution.states start).active -> - Not (HasPhase (execution.states n) node .gossiping)) := by - apply eventually_list (execution.states start).active - · intro node active - by_cases phase : - HasPhase (execution.states start) node .gossiping - · exact fair_gossip_progress execution initial fair active phase - · exact ⟨start, Nat.le_refl start, phase⟩ - · intro node first second order notGossip - exact not_gossiping_mono execution initial order notGossip - -theorem terminal_mono_step - {config : Config} - {before after : State} - {action : Action} - {node : Location} - (transition : next config before action = some after) - (terminal : Terminal before node) : - Terminal after node := by - rcases terminal with restarted | completed - · exact Or.inl (next_restarts_monotonic transition node restarted) - · exact Or.inr (next_completed_monotonic transition node completed) - -theorem terminal_mono - {config : Config} - (execution : Execution config) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (terminal : Terminal (execution.states start) node) : - Terminal (execution.states finish) node := by - induction finish, order using Nat.le_induction with - | base => exact terminal - | succ finish order terminal => - exact terminal_mono_step (execution.step_succ finish) terminal - -theorem completed_mono - {config : Config} - (execution : Execution config) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (completed : CompletedOpen (execution.states start) node) : - CompletedOpen (execution.states finish) node := by - induction finish, order using Nat.le_induction with - | base => exact completed - | succ finish order completed => - exact next_completed_monotonic - (execution.step_succ finish) node completed - -theorem quorumOpened_mono - {config : Config} - (execution : Execution config) - {start finish : Nat} - {node : Location} - (order : start <= finish) - (opened : QuorumOpened (execution.states start) node) : - QuorumOpened (execution.states finish) node := by - induction finish, order using Nat.le_induction with - | base => exact opened - | succ finish order opened => - rcases opened with - ⟨opening, membership, openingNode, kind⟩ - exact - ⟨opening, - next_openings_monotonic - (execution.step_succ finish) opening membership, - openingNode, - kind⟩ - -theorem fair_opening_completes - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - {start : Nat} - {node : Location} - (active : node ∈ (execution.states start).active) - (phase : HasPhase (execution.states start) node .opening) : - EventuallyFrom start (fun n => - CompletedOpen (execution.states n) node) := by - rcases phase with ⟨startState, foundStart, openingStart⟩ - have auxiliary : - forall distance start state, - openingDistance state.timeoutState = distance -> - node ∈ (execution.states start).active -> - Global.nodeState (execution.states start) node = some state -> - state.phase = .opening -> - EventuallyFrom start (fun n => - CompletedOpen (execution.states n) node) := by - intro distance - induction distance using Nat.strong_induction_on with - | h distance ih => - intro start state distanceEq active found opening - have enabled := - opening_timeout_enabled (config := config) - active ⟨state, found, opening⟩ - rcases fair.openingTimeout start node active - ⟨state, found, opening⟩ enabled with - ⟨timeoutAt, startTimeout, - completed | ⟨stillOpening, timeoutAction⟩⟩ - · exact ⟨timeoutAt, startTimeout, completed⟩ - · by_cases completedBefore : - CompletedOpen (execution.states timeoutAt) node - · exact ⟨timeoutAt, startTimeout, completedBefore⟩ - · rcases opening_progress_between execution initial startTimeout - found opening completedBefore with - ⟨timeoutState, foundTimeout, openingTimeout, - distanceTimeout⟩ - have timeoutStep : - next config (execution.states timeoutAt) - (.timeout node) = - some (execution.states (timeoutAt + 1)) := by - simpa [timeoutAction] using execution.step_succ timeoutAt - rcases timeout_opening_step - (reachable_well_formed - (execution_reachable execution initial timeoutAt)) - (reachable_lanes_valid - (execution_reachable execution initial timeoutAt)) - foundTimeout openingTimeout timeoutStep with - completedAfter | - ⟨nextState, foundNext, openingNext, distanceNext⟩ - · exact ⟨timeoutAt + 1, by omega, completedAfter⟩ - · have nextLess : openingDistance nextState.timeoutState < - distance := by - rw [←distanceEq] - exact Nat.lt_of_lt_of_le distanceNext distanceTimeout - rcases ih (openingDistance nextState.timeoutState) - nextLess (timeoutAt + 1) nextState rfl - (by - rw [execution_active_eq execution (timeoutAt + 1)] - rw [execution_active_eq execution start] at active - exact active) - foundNext openingNext with - ⟨completedAt, nextCompleted, completed⟩ - exact ⟨completedAt, by omega, completed⟩ - exact auxiliary (openingDistance startState.timeoutState) - start startState rfl active foundStart openingStart - -theorem initial_announcements_live - (config : Config) - (active : List Location) : - AnnouncementsLive (initial config active) := by - simp [AnnouncementsLive, Global.initial] - -theorem next_preserves_announcements_live - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (live : AnnouncementsLive before) - (transition : next config before action = some after) : - AnnouncementsLive after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, found, _, stateEq⟩ - have sourceLocation := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - intro envelope membership payload - rw [List.mem_append] at membership - rcases membership with old | added - · exact live envelope old payload - · have valid : envelope.Valid config := - retryMessages_valid config source sourceState sourceLocation - envelope added - have opening := retry_iamopen_state valid payload - have identity := retryMessages_source added - rw [identity.2] at opening - exact Or.inl - ⟨sourceState, - by simpa [identity.1] using found, - opening⟩ - | deliver delivered => - intro envelope membership payload - have details := transition - simp [next, Option.bind_eq_some_iff] at details - rcases details with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq, recordEffects_sent] at membership - rcases live envelope membership payload with - opening | completed - · rcases opening with ⟨sourceState, found, phase⟩ - rcases next_opening_progress wellFormed lanes found phase - transition with - completed | ⟨afterState, foundAfter, phaseAfter, _⟩ - · exact Or.inr completed - · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ - · exact Or.inr - (next_completed_monotonic transition envelope.source completed) - | timeout target => - intro envelope membership payload - have details := transition - simp [next, Option.bind_eq_some_iff] at details - rcases details with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq, recordEffects_sent] at membership - rcases live envelope membership payload with - opening | completed - · rcases opening with ⟨sourceState, found, phase⟩ - rcases next_opening_progress wellFormed lanes found phase - transition with - completed | ⟨afterState, foundAfter, phaseAfter, _⟩ - · exact Or.inr completed - · exact Or.inl ⟨afterState, foundAfter, phaseAfter⟩ - · exact Or.inr - (next_completed_monotonic transition envelope.source completed) - -theorem reachable_announcements_live - {config : Config} - {state : State} - (reachable : Reachable config state) : - AnnouncementsLive state := by - induction reachable with - | initial active valid nodup configured => - exact initial_announcements_live config active - | step reachable transition live => - exact next_preserves_announcements_live - (reachable_well_formed reachable) - (reachable_lanes_valid reachable) - live transition - -theorem initial_announcements_resolved - (config : Config) - (active : List Location) : - AnnouncementsResolved (initial config active) := by - simp [AnnouncementsResolved, Global.initial] - -theorem next_preserves_announcements_resolved - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (lanes : NodeLanesValid before) - (openCompleted : OpenCompleted before) - (resolved : AnnouncementsResolved before) - (transition : next config before action = some after) : - AnnouncementsResolved after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - intro envelope membership payload - rw [List.mem_append] at membership - rcases membership with old | added - · rcases resolved envelope old payload with - pending | terminal | opening - · exact Or.inl (List.mem_append_left _ pending) - · exact Or.inr (Or.inl terminal) - · exact Or.inr (Or.inr opening) - · exact Or.inl (List.mem_append_right _ added) - | deliver delivered => - intro envelope membership payload - have details := transition - simp [next, Option.bind_eq_some_iff] at details - rcases details with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq, recordEffects_sent] at membership - rcases resolved envelope membership payload with - pending | terminal | opening - · rcases mem_removeOne_or_eq pending with remains | equal - · exact Or.inl (by - rw [←stateEq, recordEffects_network] - exact remains) - · subst envelope - rcases deliver_iamopen_resolves wellFormed openCompleted payload - transition with - terminal | opening - · exact Or.inr (Or.inl terminal) - · exact Or.inr (Or.inr opening) - · exact Or.inr (Or.inl - (terminal_mono_step transition terminal)) - · rcases opening with ⟨sourceState, found, phase⟩ - rcases next_opening_progress wellFormed lanes found phase - transition with - completed | ⟨afterState, foundAfter, phaseAfter, _⟩ - · exact Or.inr (Or.inl (Or.inr completed)) - · exact Or.inr (Or.inr - ⟨afterState, foundAfter, phaseAfter⟩) - | timeout target => - intro envelope membership payload - have details := transition - simp [next, Option.bind_eq_some_iff] at details - rcases details with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq, recordEffects_sent] at membership - rcases resolved envelope membership payload with - pending | terminal | opening - · exact Or.inl (by - rw [←stateEq, recordEffects_network] - exact pending) - · exact Or.inr (Or.inl - (terminal_mono_step transition terminal)) - · rcases opening with ⟨sourceState, found, phase⟩ - rcases next_opening_progress wellFormed lanes found phase - transition with - completed | ⟨afterState, foundAfter, phaseAfter, _⟩ - · exact Or.inr (Or.inl (Or.inr completed)) - · exact Or.inr (Or.inr - ⟨afterState, foundAfter, phaseAfter⟩) - -theorem systemStep_preserves_joining_announcements - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {beforeState afterState : State} - (beforeSystem : beforeState.system = before) - (valid : JoiningAnnouncements beforeState) - (carry : - forall destination, - SentAnnouncementTo beforeState destination -> - SentAnnouncementTo afterState destination) - (introduced : - (exists source, acceptedIAmOpenSource event = some source) -> - SentAnnouncementTo afterState target) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.phase = .joining -> - SentAnnouncementTo afterState entry.1 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership joining - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · rename_i atTarget - rcases step_joining_origin config node event - (by simpa [atTarget, outputEq] using joining) with - old | received - · have keyEq : key = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - rw [←keyEq] - apply carry - apply valid (key, node) - · rw [beforeSystem] - exact List.mem_of_find?_eq_some found - · exact old - · exact introduced received - · rename_i notTarget - apply carry - apply valid previous - · rw [beforeSystem] - exact previousMember - · simpa [notTarget] using joining - -theorem initial_joining_announcements - (config : Config) - (active : List Location) : - JoiningAnnouncements (initial config active) := by - simp [JoiningAnnouncements, Global.initial, initialSystem, initialNode] - -theorem next_preserves_joining_announcements - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (valid : JoiningAnnouncements before) - (transition : next config before action = some after) : - JoiningAnnouncements after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - intro entry membership joining - rcases valid entry membership joining with - ⟨envelope, sent, target, payload⟩ - exact - ⟨envelope, List.mem_append_left _ sent, target, payload⟩ - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨inNetwork, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - intro entry membership joining - rw [recordEffects_system] at membership - let afterState := - recordEffects envelope.target output.state output.effects - { - before with - system - network := removeOne envelope before.network - } - have carry : - forall destination, - SentAnnouncementTo before destination -> - SentAnnouncementTo afterState destination := by - intro destination announcement - rcases announcement with - ⟨sentEnvelope, sent, target, payload⟩ - exact - ⟨sentEnvelope, by simpa [afterState] using sent, - target, payload⟩ - have introduced : - (exists source, - acceptedIAmOpenSource (eventFor envelope) = some source) -> - SentAnnouncementTo afterState envelope.target := by - rintro ⟨source, accepted⟩ - rcases eventFor_iamopen_source accepted with - ⟨payload, _⟩ - exact - ⟨envelope, - by - simp [afterState] - exact wellFormed.networkSent envelope inNetwork, - rfl, payload⟩ - exact systemStep_preserves_joining_announcements - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl valid carry introduced systemStep - entry membership joining - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - intro entry membership joining - rw [recordEffects_system] at membership - let afterState := - recordEffects target output.state output.effects - { before with system } - have carry : - forall destination, - SentAnnouncementTo before destination -> - SentAnnouncementTo afterState destination := by - intro destination announcement - rcases announcement with - ⟨sentEnvelope, sent, target, payload⟩ - exact - ⟨sentEnvelope, by simpa [afterState] using sent, - target, payload⟩ - have introduced : - (exists source, - acceptedIAmOpenSource Event.timeout = some source) -> - SentAnnouncementTo afterState target := by - rintro ⟨source, accepted⟩ - simp [acceptedIAmOpenSource] at accepted - exact systemStep_preserves_joining_announcements - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl valid carry introduced systemStep - entry membership joining - -theorem reachable_joining_announcements - {config : Config} - {state : State} - (reachable : Reachable config state) : - JoiningAnnouncements state := by - induction reachable with - | initial active valid nodup configured => - exact initial_joining_announcements config active - | step reachable transition valid => - exact next_preserves_joining_announcements - (reachable_well_formed reachable) valid transition - -theorem systemStep_preserves_open_completed - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {beforeState afterState : State} - (beforeSystem : beforeState.system = before) - (valid : OpenCompleted beforeState) - (carry : - forall node, - CompletedOpen beforeState node -> - CompletedOpen afterState node) - (introduced : - .completed ∈ output.effects -> - CompletedOpen afterState target) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.phase = .open -> - CompletedOpen afterState entry.1 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership opened - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · rename_i atTarget - rcases step_open_origin config node event - (by simpa [atTarget, outputEq] using opened) with - old | completed - · have keyEq : key = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - rw [←keyEq] - apply carry - apply valid (key, node) - · rw [beforeSystem] - exact List.mem_of_find?_eq_some found - · exact old - · rw [outputEq] at completed - exact introduced completed - · rename_i notTarget - apply carry - apply valid previous - · rw [beforeSystem] - exact previousMember - · simpa [notTarget] using opened - -theorem initial_open_completed - (config : Config) - (active : List Location) : - OpenCompleted (initial config active) := by - simp [OpenCompleted, Global.initial, initialSystem, initialNode] - -theorem next_preserves_open_completed - {config : Config} - {before after : State} - {action : Action} - (valid : OpenCompleted before) - (transition : next config before action = some after) : - OpenCompleted after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - exact valid - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - intro entry membership opened - rw [recordEffects_system] at membership - let afterState := - recordEffects envelope.target output.state output.effects - { - before with - system - network := removeOne envelope before.network - } - have carry : - forall node, - CompletedOpen before node -> - CompletedOpen afterState node := by - intro node completed - apply mem_completed_recordEffects - exact completed - have introduced : - .completed ∈ output.effects -> - CompletedOpen afterState envelope.target := by - intro completed - exact completed_effect_recorded completed - exact systemStep_preserves_open_completed - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl valid carry introduced systemStep entry membership opened - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - intro entry membership opened - rw [recordEffects_system] at membership - let afterState := - recordEffects target output.state output.effects - { before with system } - have carry : - forall node, - CompletedOpen before node -> - CompletedOpen afterState node := by - intro node completed - apply mem_completed_recordEffects - exact completed - have introduced : - .completed ∈ output.effects -> - CompletedOpen afterState target := by - intro completed - exact completed_effect_recorded completed - exact systemStep_preserves_open_completed - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl valid carry introduced systemStep entry membership opened - -theorem reachable_open_completed - {config : Config} - {state : State} - (reachable : Reachable config state) : - OpenCompleted state := by - induction reachable with - | initial active valid nodup configured => - exact initial_open_completed config active - | step reachable transition valid => - exact next_preserves_open_completed valid transition - -theorem reachable_announcements_resolved - {config : Config} - {state : State} - (reachable : Reachable config state) : - AnnouncementsResolved state := by - induction reachable with - | initial active valid nodup configured => - exact initial_announcements_resolved config active - | step reachable transition resolved => - exact next_preserves_announcements_resolved - (reachable_well_formed reachable) - (reachable_lanes_valid reachable) - (reachable_open_completed reachable) - resolved transition - -theorem open_node_completed - {state : State} - {node : Location} - {nodeState : NodeState} - (valid : OpenCompleted state) - (found : Global.nodeState state node = some nodeState) - (opened : nodeState.phase = .open) : - CompletedOpen state node := by - rw [Global.nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have keyEq : entry.1 = node := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) findEq) - rw [←keyEq] - apply valid entry (List.mem_of_find?_eq_some findEq) - simpa [stateEq] using opened - -theorem joining_node_announcement - {state : State} - {node : Location} - {nodeState : NodeState} - (valid : JoiningAnnouncements state) - (found : Global.nodeState state node = some nodeState) - (joining : nodeState.phase = .joining) : - SentAnnouncementTo state node := by - rw [Global.nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have keyEq : entry.1 = node := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) findEq) - rw [←keyEq] - apply valid entry (List.mem_of_find?_eq_some findEq) - simpa [stateEq] using joining - -theorem openerWitness_of_later_phase - {config : Config} - {state : State} - {node : Location} - (reachable : Reachable config state) - (active : node ∈ state.active) - (notGossip : Not (HasPhase state node .gossiping)) - (notVoting : Not (HasPhase state node .voting)) : - OpenerWitness state := by - rcases active_nodeState (reachable_well_formed reachable) active with - ⟨nodeState, found⟩ - cases phase : nodeState.phase with - | gossiping => - exact False.elim - (notGossip ⟨nodeState, found, phase⟩) - | voting => - exact False.elim - (notVoting ⟨nodeState, found, phase⟩) - | opening => - exact ⟨node, Or.inl ⟨nodeState, found, phase⟩⟩ - | joining => - rcases joining_node_announcement - (reachable_joining_announcements reachable) - found phase with - ⟨envelope, sent, target, payload⟩ - rcases reachable_announcements_live reachable - envelope sent payload with - opening | completed - · exact ⟨envelope.source, Or.inl opening⟩ - · exact ⟨envelope.source, Or.inr completed⟩ - | «open» => - exact - ⟨node, Or.inr - (open_node_completed - (reachable_open_completed reachable) found phase)⟩ - -theorem openerWitness_after_leave_voting - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - {start later : Nat} - {node : Location} - (order : start <= later) - (allPastGossip : - forall activeNode, - activeNode ∈ (execution.states start).active -> - Not (HasPhase (execution.states start) - activeNode .gossiping)) - (active : node ∈ (execution.states later).active) - (notVoting : - Not (HasPhase (execution.states later) node .voting)) : - OpenerWitness (execution.states later) := by - have activeStart : node ∈ (execution.states start).active := by - rw [execution_active_eq execution later] at active - rw [execution_active_eq execution start] - exact active - have notGossip := - not_gossiping_mono execution initial order - (allPastGossip node activeStart) - exact openerWitness_of_later_phase - (execution_reachable execution initial later) - active notGossip notVoting - -theorem systemStep_preserves_advanced_active - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {active : List Location} - (valid : - forall entry, entry ∈ before.nodes -> - entry.2.phase ≠ .gossiping -> - entry.1 ∈ active) - (targetActive : target ∈ active) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.phase ≠ .gossiping -> - entry.1 ∈ active := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership advanced - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · exact targetActive - · rename_i notTarget - exact valid previous previousMember - (by simpa [notTarget] using advanced) - -theorem initial_advanced_active - (config : Config) - (active : List Location) : - AdvancedNodesActive (initial config active) := by - simp [AdvancedNodesActive, Global.initial, initialSystem, initialNode] - -theorem next_preserves_advanced_active - {config : Config} - {before after : State} - {action : Action} - (valid : AdvancedNodesActive before) - (transition : next config before action = some after) : - AdvancedNodesActive after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - exact valid - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, targetActive, system, output, systemStep, stateEq⟩ - rw [←stateEq] - intro entry membership advanced - rw [recordEffects_system] at membership - simpa using - systemStep_preserves_advanced_active - valid targetActive systemStep entry membership advanced - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨targetActive, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - intro entry membership advanced - rw [recordEffects_system] at membership - simpa using - systemStep_preserves_advanced_active - valid targetActive systemStep entry membership advanced - -theorem reachable_advanced_active - {config : Config} - {state : State} - (reachable : Reachable config state) : - AdvancedNodesActive state := by - induction reachable with - | initial active valid nodup configured => - exact initial_advanced_active config active - | step reachable transition valid => - exact next_preserves_advanced_active valid transition - -theorem hasPhase_active - {config : Config} - {state : State} - {node : Location} - {phase : Phase} - (reachable : Reachable config state) - (hasPhase : HasPhase state node phase) - (advancedPhase : phase ≠ .gossiping) : - node ∈ state.active := by - rcases hasPhase with ⟨nodeState, found, phaseEq⟩ - rw [Global.nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have keyEq : entry.1 = node := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) findEq) - rw [←keyEq] - apply reachable_advanced_active reachable entry - (List.mem_of_find?_eq_some findEq) - rw [stateEq, phaseEq] - exact advancedPhase - -theorem fair_opener_witness - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - {start : Nat} - (activeNonempty : (execution.states start).active ≠ []) - (allPastGossip : - forall node, node ∈ (execution.states start).active -> - Not (HasPhase (execution.states start) node .gossiping)) : - EventuallyFrom start (fun n => - OpenerWitness (execution.states n)) := by - obtain ⟨voter, voterActive⟩ := - List.exists_mem_of_ne_nil _ activeNonempty - by_cases voting : - HasPhase (execution.states start) voter .voting - · rcases voting with ⟨voterState, foundVoter, voterVoting⟩ - have selectionProperty := - node_property_of_nodeState - (predicate := fun state => - state.phase = .voting -> NodeVotingSelection state) - (reachable_quorum_invariant - (execution_reachable execution initial start)).votingSelections - foundVoter - rcases selectionProperty voterVoting with - ⟨target, txid, chosen, maximum⟩ - have retryEnabled := - retry_voting_enabled (config := config) - voterActive foundVoter voterVoting chosen - rcases fair.retry start voter .voting voterActive - ⟨voterState, foundVoter, voterVoting⟩ - (Or.inr (Or.inl rfl)) retryEnabled with - ⟨retryAt, startRetry, leftVoting | retryAction⟩ - · exact - ⟨retryAt, startRetry, - openerWitness_after_leave_voting execution initial - startRetry allPastGossip - (by - rw [execution_active_eq execution retryAt] - rw [execution_active_eq execution start] at voterActive - exact voterActive) - leftVoting⟩ - · by_cases retryVoting : - HasPhase (execution.states retryAt) voter .voting - · rcases retryVoting with - ⟨retryState, foundRetry, votingRetry⟩ - have retrySelectionProperty := - node_property_of_nodeState - (predicate := fun state => - state.phase = .voting -> NodeVotingSelection state) - (reachable_quorum_invariant - (execution_reachable execution initial retryAt)).votingSelections - foundRetry - rcases retrySelectionProperty votingRetry with - ⟨retryTarget, retryTxID, retryChosen, retryMaximum⟩ - have retryStep : - next config (execution.states retryAt) (.retry voter) = - some (execution.states (retryAt + 1)) := by - simpa [retryAction] using execution.step_succ retryAt - rcases retry_vote_enqueued foundRetry votingRetry retryChosen - retryStep with - ⟨voteEnvelope, pending, voteSource, voteTarget, votePayload⟩ - rcases fair.delivery (retryAt + 1) voteEnvelope pending with - ⟨deliverAt, retryDeliver, deliverAction⟩ - have deliverStep : - next config (execution.states deliverAt) - (.deliver voteEnvelope) = - some (execution.states (deliverAt + 1)) := by - simpa [deliverAction] using execution.step_succ deliverAt - have deliverDetails := deliverStep - simp [next, Option.bind_eq_some_iff] at deliverDetails - have targetActive : voteEnvelope.target ∈ - (execution.states deliverAt).active := - deliverDetails.2.1 - by_cases targetVoting : - HasPhase (execution.states deliverAt) - voteEnvelope.target .voting - · rcases deliver_vote_progress - (reachable_well_formed - (execution_reachable execution initial deliverAt)) - votePayload targetVoting deliverStep with - leftAfter | hasVote - · have activeAfter : voteEnvelope.target ∈ - (execution.states (deliverAt + 1)).active := by - rw [execution_active_eq execution (deliverAt + 1)] - rw [execution_active_eq execution deliverAt] at targetActive - exact targetActive - exact - ⟨deliverAt + 1, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip activeAfter leftAfter⟩ - · by_cases votingAfter : - HasPhase (execution.states (deliverAt + 1)) - voteEnvelope.target .voting - · have activeAfter : voteEnvelope.target ∈ - (execution.states (deliverAt + 1)).active := by - rw [execution_active_eq execution (deliverAt + 1)] - rw [execution_active_eq execution deliverAt] at targetActive - exact targetActive - have timeoutEnabled := - voting_timeout_enabled (config := config) - activeAfter votingAfter - rcases fair.timeout (deliverAt + 1) - voteEnvelope.target .voting activeAfter votingAfter - (Or.inr (Or.inl rfl)) timeoutEnabled with - ⟨timeoutAt, deliverTimeout, - leftBeforeTimeout | timeoutAction⟩ - · exact - ⟨timeoutAt, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip - (by - rw [execution_active_eq execution timeoutAt] - rw [execution_active_eq execution - (deliverAt + 1)] at activeAfter - exact activeAfter) - leftBeforeTimeout⟩ - · by_cases votingAtTimeout : - HasPhase (execution.states timeoutAt) - voteEnvelope.target .voting - · have voteAtTimeout := - hasVote_mono execution initial deliverTimeout hasVote - have timeoutStep : - next config (execution.states timeoutAt) - (.timeout voteEnvelope.target) = - some (execution.states (timeoutAt + 1)) := by - simpa [timeoutAction] using - execution.step_succ timeoutAt - rcases timeout_voting_step - (reachable_well_formed - (execution_reachable execution initial timeoutAt)) - (reachable_lanes_valid - (execution_reachable execution initial timeoutAt)) - votingAtTimeout voteAtTimeout timeoutStep with - opened | - ⟨waitingState, foundWaiting, waitingPhase, - waitingLane, waitingVotes⟩ - · exact - ⟨timeoutAt + 1, by omega, - ⟨voteEnvelope.target, Or.inl opened⟩⟩ - · have activeWaiting : voteEnvelope.target ∈ - (execution.states (timeoutAt + 1)).active := by - rw [execution_active_eq execution (timeoutAt + 1)] - rw [execution_active_eq execution - (deliverAt + 1)] at activeAfter - exact activeAfter - have secondEnabled := - voting_timeout_enabled (config := config) - activeWaiting - ⟨waitingState, foundWaiting, waitingPhase⟩ - rcases fair.timeout (timeoutAt + 1) - voteEnvelope.target .voting activeWaiting - ⟨waitingState, foundWaiting, waitingPhase⟩ - (Or.inr (Or.inl rfl)) secondEnabled with - ⟨secondAt, firstSecond, - leftBeforeSecond | secondAction⟩ - · exact - ⟨secondAt, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip - (by - rw [execution_active_eq execution secondAt] - rw [execution_active_eq execution - (timeoutAt + 1)] at activeWaiting - exact activeWaiting) - leftBeforeSecond⟩ - · by_cases votingAtSecond : - HasPhase (execution.states secondAt) - voteEnvelope.target .voting - · rcases votingAtSecond with - ⟨secondState, foundSecond, secondPhase⟩ - have votesSecond := - hasVote_mono execution initial firstSecond - ⟨waitingState, foundWaiting, waitingVotes⟩ - rcases votesSecond with - ⟨voteState, foundVotes, secondVotes⟩ - rw [foundSecond] at foundVotes - injection foundVotes with voteStateEq - subst voteState - have advancedSecond := - advanced_lane_mono execution initial firstSecond - ⟨waitingState, foundWaiting, by simp [waitingLane]⟩ - rcases advancedSecond with - ⟨laneState, foundLane, advanced⟩ - rw [foundSecond] at foundLane - injection foundLane with laneStateEq - subst laneState - have laneValid : LaneValid secondState := by - apply node_property_of_nodeState - (predicate := LaneValid) - · exact reachable_lanes_valid - (execution_reachable execution initial secondAt) - · exact foundSecond - have secondLane : secondState.timeoutState = - .voting := by - rcases laneValid.2.1 secondPhase with - gossipLane | votingLane - · contradiction - · exact votingLane - have secondStep : - next config (execution.states secondAt) - (.timeout voteEnvelope.target) = - some (execution.states (secondAt + 1)) := by - simpa [secondAction] using - execution.step_succ secondAt - have opened := - aligned_timeout_voting_opens - (reachable_well_formed - (execution_reachable execution initial secondAt)) - foundSecond secondPhase secondLane secondVotes - secondStep - exact - ⟨secondAt + 1, by omega, - ⟨voteEnvelope.target, Or.inl opened⟩⟩ - · exact - ⟨secondAt, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip - (by - rw [execution_active_eq execution secondAt] - rw [execution_active_eq execution - (timeoutAt + 1)] at activeWaiting - exact activeWaiting) - votingAtSecond⟩ - · exact - ⟨timeoutAt, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip - (by - rw [execution_active_eq execution timeoutAt] - rw [execution_active_eq execution - (deliverAt + 1)] at activeAfter - exact activeAfter) - votingAtTimeout⟩ - · exact - ⟨deliverAt + 1, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip - (by - rw [execution_active_eq execution (deliverAt + 1)] - rw [execution_active_eq execution deliverAt] - at targetActive - exact targetActive) - votingAfter⟩ - · exact - ⟨deliverAt, by omega, - openerWitness_after_leave_voting execution initial - (by omega) allPastGossip targetActive targetVoting⟩ - · exact - ⟨retryAt, startRetry, - openerWitness_after_leave_voting execution initial - startRetry allPastGossip - (by - rw [execution_active_eq execution retryAt] - rw [execution_active_eq execution start] at voterActive - exact voterActive) - retryVoting⟩ - · exact - ⟨start, Nat.le_refl start, - openerWitness_after_leave_voting execution initial - (Nat.le_refl start) allPastGossip voterActive voting⟩ - -theorem openerWitness_eventually_completes - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - {start : Nat} - (witness : OpenerWitness (execution.states start)) : - EventuallyFrom start (fun n => - exists node, CompletedOpen (execution.states n) node) := by - rcases witness with ⟨node, opening | completed⟩ - · have active := - hasPhase_active (execution_reachable execution initial start) - opening (by simp) - rcases fair_opening_completes execution initial fair active opening with - ⟨completedAt, order, completed⟩ - exact ⟨completedAt, order, node, completed⟩ - · exact ⟨start, Nat.le_refl start, node, completed⟩ - -theorem fair_some_opener_completes - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (activeNonempty : (execution.states 0).active ≠ []) : - EventuallyFrom 0 (fun n => - exists node, CompletedOpen (execution.states n) node) := by - rcases fair_all_leave_gossip execution initial fair 0 with - ⟨pastGossipAt, _, allPastGossip⟩ - have nonemptyAt : - (execution.states pastGossipAt).active ≠ [] := by - rw [execution_active_eq execution pastGossipAt] - exact activeNonempty - have allPastAt : - forall node, node ∈ (execution.states pastGossipAt).active -> - Not (HasPhase (execution.states pastGossipAt) - node .gossiping) := by - intro node active - rw [execution_active_eq execution pastGossipAt] at active - exact allPastGossip node active - rcases fair_opener_witness execution initial fair nonemptyAt - allPastAt with - ⟨witnessAt, pastWitness, witness⟩ - rcases openerWitness_eventually_completes execution initial fair - witness with - ⟨completedAt, witnessCompleted, completed⟩ - exact ⟨completedAt, by omega, completed⟩ - -theorem fair_target_terminal_after_completion - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (broadcast : BroadcastBeforeCompletion execution) - {start : Nat} - {opener target : Location} - (completed : CompletedOpen (execution.states start) opener) - (active : target ∈ (execution.states start).active) : - EventuallyFrom start (fun n => - Terminal (execution.states n) target) := by - by_cases same : target = opener - · subst target - exact ⟨start, Nat.le_refl start, Or.inr completed⟩ - · rcases broadcast start opener completed target active same with - ⟨envelope, sent, sourceEq, targetEq, payload⟩ - rcases reachable_announcements_resolved - (execution_reachable execution initial start) - envelope sent payload with - pending | terminal | opening - · rcases fair.delivery start envelope pending with - ⟨deliverAt, startDelivery, deliverAction⟩ - have deliverStep : - next config (execution.states deliverAt) (.deliver envelope) = - some (execution.states (deliverAt + 1)) := by - simpa [deliverAction] using execution.step_succ deliverAt - rcases deliver_iamopen_resolves - (reachable_well_formed - (execution_reachable execution initial deliverAt)) - (reachable_open_completed - (execution_reachable execution initial deliverAt)) - payload deliverStep with - terminal | targetOpening - · exact - ⟨deliverAt + 1, by omega, by simpa [targetEq] using terminal⟩ - · have openingActive := - hasPhase_active - (execution_reachable execution initial (deliverAt + 1)) - targetOpening (by simp) - rcases fair_opening_completes execution initial fair - openingActive targetOpening with - ⟨completedAt, deliveryCompleted, targetCompleted⟩ - exact - ⟨completedAt, by omega, - by simpa [targetEq] using (Or.inr targetCompleted)⟩ - · exact - ⟨start, Nat.le_refl start, by simpa [targetEq] using terminal⟩ - · have openingActive := - hasPhase_active - (execution_reachable execution initial start) - opening (by simp) - rcases fair_opening_completes execution initial fair - openingActive opening with - ⟨completedAt, startCompleted, targetCompleted⟩ - exact - ⟨completedAt, startCompleted, - by simpa [targetEq] using (Or.inr targetCompleted)⟩ - -theorem fair_all_terminal_after_completion - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (broadcast : BroadcastBeforeCompletion execution) - {start : Nat} - {opener : Location} - (completed : CompletedOpen (execution.states start) opener) : - EventuallyFrom start (fun n => - forall node, node ∈ (execution.states start).active -> - Terminal (execution.states n) node) := by - apply eventually_list (execution.states start).active - · intro node active - exact fair_target_terminal_after_completion - execution initial fair broadcast completed active - · intro node first second order terminal - exact terminal_mono execution order terminal - -theorem global_progress - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (broadcast : BroadcastBeforeCompletion execution) - (activeNonempty : (execution.states 0).active ≠ []) : - EventuallyFrom 0 (fun n => - exists node, CompletedOpen (execution.states n) node) /\ - EventuallyFrom 0 (fun n => - forall node, node ∈ (execution.states 0).active -> - Terminal (execution.states n) node) := by - have completed := - fair_some_opener_completes execution initial fair activeNonempty - constructor - · exact completed - · rcases completed with - ⟨completedAt, _, opener, openerCompleted⟩ - rcases fair_all_terminal_after_completion execution initial fair - broadcast openerCompleted with - ⟨terminalAt, completedTerminal, allTerminal⟩ - refine ⟨terminalAt, by omega, ?_⟩ - intro node active - apply allTerminal node - rw [execution_active_eq execution completedAt] - exact active - -theorem single_completion_path_joins_others - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (broadcast : BroadcastBeforeCompletion execution) - {start : Nat} - {opener : Location} - (completed : CompletedOpen (execution.states start) opener) - (onlyOpener : OnlyOpenerCompletesFrom execution start opener) : - EventuallyFrom start (fun n => - forall node, node ∈ (execution.states start).active -> - node = opener \/ node ∈ (execution.states n).restarts) := by - apply eventually_list (execution.states start).active - · intro node active - by_cases same : node = opener - · exact ⟨start, Nat.le_refl start, Or.inl same⟩ - · rcases fair_target_terminal_after_completion - execution initial fair broadcast completed active with - ⟨terminalAt, startTerminal, terminal⟩ - rcases terminal with restarted | targetCompleted - · exact ⟨terminalAt, startTerminal, Or.inr restarted⟩ - · exact False.elim - (same - (onlyOpener terminalAt node startTerminal targetCompleted)) - · intro node first second order joined - rcases joined with same | restarted - · exact Or.inl same - · exact Or.inr - (by - induction second, order using Nat.le_induction with - | base => exact restarted - | succ second order restarted => - exact next_restarts_monotonic - (execution.step_succ second) node restarted) - -theorem quorum_path_progress - {config : Config} - (execution : Execution config) - (initial : Reachable config (execution.states 0)) - (fair : Fair execution) - (broadcast : BroadcastBeforeCompletion execution) - {start : Nat} - {opener : Location} - (opened : QuorumOpened (execution.states start) opener) - (completed : CompletedOpen (execution.states start) opener) - (quorumOnly : QuorumOnlyCompletions execution) : - QuorumOpened (execution.states start) opener /\ - CompletedOpen (execution.states start) opener /\ - EventuallyFrom start (fun n => - forall node, node ∈ (execution.states start).active -> - node = opener \/ node ∈ (execution.states n).restarts) := by - have onlyOpener : - OnlyOpenerCompletesFrom execution start opener := by - intro n node startN nodeCompleted - exact quorum_opener_unique - (execution_reachable execution initial n) - (quorumOnly n node nodeCompleted) - (quorumOpened_mono execution startN opened) - exact - ⟨opened, completed, - single_completion_path_joins_others - execution initial fair broadcast completed onlyOpener⟩ - end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean index dbe145561f1..d9a96580b85 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Invariants.lean @@ -1,5 +1,6 @@ import DisasterRecovery.Protocol.Global -import Mathlib.Tactic + +/-! Human-reviewed reachability and message-provenance invariants. -/ namespace DisasterRecovery.Protocol.Global @@ -37,863 +38,4 @@ structure WellFormed (config : Config) (state : State) : Prop where envelope ∈ state.sent historiesActive : HistoriesActive state -theorem messageForEffect_source - {config : Config} - {source : Location} - {sourceState : NodeState} - {effect : Effect} - {envelope : Envelope} - (created : - messageForEffect config source sourceState effect = some envelope) : - envelope.source = source /\ - envelope.sourceState = sourceState := by - cases effect with - | sendGossip target => - cases found : recoveredTxID config source with - | none => - simp [messageForEffect, found] at created - | some txid => - simp [messageForEffect, found] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | sendVote target => - simp [messageForEffect] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] - exact ⟨rfl, rfl⟩ - | opening kind => - simp_all [messageForEffect] - | restart chosen => - simp_all [messageForEffect] - | completed => - simp_all [messageForEffect] - | rejected reason => - simp_all [messageForEffect] - -theorem retryMessages_source - {config : Config} - {source : Location} - {sourceState : NodeState} - {envelope : Envelope} - (created : - envelope ∈ retryMessages config source sourceState) : - envelope.source = source /\ - envelope.sourceState = sourceState := by - rw [retryMessages, List.mem_filterMap] at created - rcases created with ⟨effect, _, produced⟩ - exact messageForEffect_source produced - -theorem retryMessages_valid - (config : Config) - (source : Location) - (sourceState : NodeState) - (sourceLocation : sourceState.location = source) : - forall envelope, - envelope ∈ retryMessages config source sourceState -> - envelope.Valid config := by - intro envelope created - rcases retryMessages_source created with - ⟨sourceEq, stateEq⟩ - constructor - · rw [stateEq, sourceEq] - exact sourceLocation - · rw [sourceEq, stateEq] - exact created - -theorem valid_envelope_effect - {config : Config} - {envelope : Envelope} - (valid : envelope.Valid config) : - exists effect, - effect ∈ - (step config.protocol envelope.sourceState .retry).effects /\ - messageForEffect config envelope.source - envelope.sourceState effect = some envelope := by - rcases valid with ⟨_, created⟩ - rw [retryMessages, List.mem_filterMap] at created - exact created - -theorem valid_gossip_uses_recovered_txid - {config : Config} - {envelope : Envelope} - {txid : TxID} - (valid : envelope.Valid config) - (gossip : envelope.payload = .gossip txid) : - recoveredTxID config envelope.source = some txid := by - rcases valid_envelope_effect valid with - ⟨effect, _, created⟩ - cases effect with - | sendGossip target => - cases found : recoveredTxID config envelope.source with - | none => - simp [messageForEffect, found] at created - | some recovered => - simp [messageForEffect, found] at created - rw [←created] at gossip - injection gossip with same - subst recovered - rfl - | sendVote target => - simp [messageForEffect] at created - rw [←created] at gossip - contradiction - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] at gossip - contradiction - | opening kind => - simp [messageForEffect] at created - | restart chosen => - simp [messageForEffect] at created - | completed => - simp [messageForEffect] at created - | rejected reason => - simp [messageForEffect] at created - -theorem step_preserves_location - (config : Protocol.Config) - (state : NodeState) - (event : Event) : - (step config state event).state.location = state.location := by - cases event <;> - simp [step, rejected, advance, advanceTimeoutLane] - all_goals repeat first | split | simp_all - -theorem nodeState_location - {state : State} - {node : Location} - {foundState : NodeState} - (locations : - forall entry, entry ∈ state.system.nodes -> - entry.2.location = entry.1) - (found : nodeState state node = some foundState) : - foundState.location = node := by - rw [nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have membership : entry ∈ state.system.nodes := - List.mem_of_find?_eq_some findEq - have condition : (entry.1 == node) = true := - List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == node) findEq - have keyEq : entry.1 = node := beq_iff_eq.mp condition - rw [←stateEq, locations entry membership, keyEq] - -theorem initial_well_formed - (config : Config) - (active : List Location) - (valid : config.Valid) - (activeNodup : active.Nodup) - (activeConfigured : - forall node, node ∈ active -> - node ∈ config.protocol.expectedLocations) : - WellFormed config (initial config active) := by - constructor - · simp [Global.initial, initialSystem, Function.comp_def] - · simpa [Global.initial, initialSystem, Function.comp_def] using valid.2.1 - · simp [Global.initial, initialSystem, initialNode] - · exact activeNodup - · exact activeConfigured - · simp [Global.initial] - · simp [Global.initial] - · simp [Global.initial] - · constructor <;> simp [Global.initial] - -@[simp] -theorem recordEffects_active - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).active = state.active := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).active = - state.active - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_system - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).system = state.system := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).system = - state.system - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_network - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).network = state.network := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).network = - state.network - rw [ih] - cases effect <;> rfl - -@[simp] -theorem recordEffects_sent - (node : Location) - (nodeState : NodeState) - (effects : List Effect) - (state : State) : - (recordEffects node nodeState effects state).sent = state.sent := by - induction effects generalizing state with - | nil => rfl - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - change - (recordEffects node nodeState tail - (recordEffect node nodeState state effect)).sent = - state.sent - rw [ih] - cases effect <;> rfl - -theorem recordEffect_preserves_histories_active - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - (wellFormed : HistoriesActive state) - (nodeActive : node ∈ state.active) : - HistoriesActive (recordEffect node nodeState state effect) := by - rcases wellFormed with ⟨openings, restarts, completed⟩ - cases effect <;> - constructor <;> - simp_all [recordEffect] - -theorem recordEffects_preserves_histories_active - {node : Location} - {nodeState : NodeState} - {effects : List Effect} - {state : State} - (wellFormed : HistoriesActive state) - (nodeActive : node ∈ state.active) : - HistoriesActive (recordEffects node nodeState effects state) := by - induction effects generalizing state with - | nil => exact wellFormed - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - apply ih - · exact recordEffect_preserves_histories_active wellFormed nodeActive - · cases effect <;> simpa [recordEffect] using nodeActive - -theorem mem_of_mem_removeOne - [BEq α] - (value member : α) - (values : List α) : - member ∈ removeOne value values -> - member ∈ values := by - induction values with - | nil => simp [removeOne] - | cons head tail ih => - simp only [removeOne] - split - · exact List.mem_cons_of_mem head - · intro membership - rw [List.mem_cons] at membership ⊢ - exact membership.imp_right ih - -theorem mem_openings_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {opening : Opening} - (membership : opening ∈ state.openings) : - opening ∈ (recordEffect node nodeState state effect).openings := by - cases effect <;> simp_all [recordEffect] - -theorem mem_restarts_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {restart : Location} - (membership : restart ∈ state.restarts) : - restart ∈ (recordEffect node nodeState state effect).restarts := by - cases effect <;> simp_all [recordEffect] - -theorem mem_completed_recordEffect - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - {completed : Location} - (membership : completed ∈ state.completed) : - completed ∈ (recordEffect node nodeState state effect).completed := by - cases effect <;> simp_all [recordEffect] - -theorem mem_openings_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {opening : Opening} - (membership : opening ∈ state.openings) : - opening ∈ (recordEffects node nodeState effects state).openings := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_openings_recordEffect membership) - -theorem mem_restarts_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {restart : Location} - (membership : restart ∈ state.restarts) : - restart ∈ (recordEffects node nodeState effects state).restarts := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_restarts_recordEffect membership) - -theorem mem_completed_recordEffects - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - {completed : Location} - (membership : completed ∈ state.completed) : - completed ∈ (recordEffects node nodeState effects state).completed := by - induction effects generalizing state with - | nil => exact membership - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - exact ih (mem_completed_recordEffect membership) - -theorem replaceNode_keys - (target : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) : - (replaceNode target nextState nodes).map Prod.fst = - nodes.map Prod.fst := by - induction nodes with - | nil => rfl - | cons entry tail ih => - simp only [replaceNode, List.map_cons] - split - · - rename_i condition - have same : entry.1 = target := beq_iff_eq.mp condition - simp only [List.cons.injEq] - constructor - · exact same.symm - · simpa [replaceNode] using ih - · - simp only [List.cons.injEq, true_and] - simpa [replaceNode] using ih - -theorem replaceNode_locations - (target : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) - (locations : - forall entry, entry ∈ nodes -> - entry.2.location = entry.1) - (nextLocation : nextState.location = target) : - forall entry, entry ∈ replaceNode target nextState nodes -> - entry.2.location = entry.1 := by - intro entry membership - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · exact nextLocation - · exact locations previous previousMember - -theorem findNode_replaceNode_ne - (target other : Location) - (nextState : NodeState) - (nodes : List (Prod Location NodeState)) - (different : other ≠ target) : - ((replaceNode target nextState nodes).find? - fun entry => entry.1 == other).map Prod.snd = - (nodes.find? fun entry => entry.1 == other).map Prod.snd := by - let replace : Prod Location NodeState -> Prod Location NodeState := - fun entry => - if entry.1 == target then (target, nextState) else entry - change - Option.map Prod.snd - (List.find? (fun entry => entry.1 == other) - (nodes.map replace)) = - Option.map Prod.snd - (List.find? (fun entry => entry.1 == other) nodes) - rw [List.find?_map] - have predicate : - ((fun entry : Prod Location NodeState => entry.1 == other) ∘ - replace) = - (fun entry => entry.1 == other) := by - funext entry - by_cases atTarget : entry.1 = target - · simp [replace, atTarget] - · simp [replace, atTarget] - rw [predicate] - cases found : - List.find? (fun entry : Prod Location NodeState => - entry.1 == other) nodes with - | none => simp - | some entry => - have condition : - (entry.1 == other) = true := - List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == other) found - have entryOther : entry.1 = other := - beq_iff_eq.mp condition - have notTarget : entry.1 ≠ target := by - simpa [entryOther] using different - simp [replace, notTarget] - -theorem systemStep_node_keys_eq - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (transition : - systemStep config before target event = some (after, output)) : - after.nodes.map Prod.fst = before.nodes.map Prod.fst := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with ⟨node, _, stateEq, _⟩ - rw [←stateEq] - exact replaceNode_keys target - (step config node event).state before.nodes - -theorem systemStep_preserves_node_locations - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (locations : - forall entry, entry ∈ before.nodes -> - entry.2.location = entry.1) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.location = entry.1 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, stateEq, _⟩ - rw [←stateEq] - apply replaceNode_locations - · exact locations - · calc - (step config node event).state.location = - node.location := step_preserves_location config node event - _ = key := - locations (key, node) (List.mem_of_find?_eq_some found) - _ = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - -theorem systemStep_other_node_eq - {config : Protocol.Config} - {before after : SystemState} - {target other : Location} - {event : Event} - {output : StepOutput} - (different : other ≠ target) - (transition : - systemStep config before target event = some (after, output)) : - (after.nodes.find? fun entry => entry.1 == other).map Prod.snd = - (before.nodes.find? fun entry => entry.1 == other).map Prod.snd := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with ⟨node, _, stateEq, _⟩ - rw [←stateEq] - exact findNode_replaceNode_ne target other - (step config node event).state before.nodes different - -theorem next_active_eq - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - after.active = before.active := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, _, system, output, _, rfl⟩ - simp - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, system, output, _, _, rfl⟩ - simp - -theorem next_node_keys_eq - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - after.system.nodes.map Prod.fst = - before.system.nodes.map Prod.fst := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, _, system, output, systemStep, rfl⟩ - simpa using systemStep_node_keys_eq systemStep - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, system, output, systemStep, _, rfl⟩ - simpa using systemStep_node_keys_eq systemStep - -theorem retry_system_eq - {config : Config} - {before after : State} - {source : Location} - (transition : next config before (.retry source) = some after) : - after.system = before.system := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - rfl - -theorem deliver_network_eq - {config : Config} - {before after : State} - {envelope : Envelope} - (transition : next config before (.deliver envelope) = some after) : - after.network = removeOne envelope before.network := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - simp - -theorem timeout_network_eq - {config : Config} - {before after : State} - {target : Location} - (transition : next config before (.timeout target) = some after) : - after.network = before.network := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - simp - -theorem deliver_other_node_eq - {config : Config} - {before after : State} - {envelope : Envelope} - {other : Location} - (different : other ≠ envelope.target) - (transition : next config before (.deliver envelope) = some after) : - nodeState after other = nodeState before other := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - simp only [nodeState, recordEffects_system] - exact systemStep_other_node_eq different systemStep - -theorem timeout_other_node_eq - {config : Config} - {before after : State} - {target other : Location} - (different : other ≠ target) - (transition : next config before (.timeout target) = some after) : - nodeState after other = nodeState before other := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - simp only [nodeState, recordEffects_system] - exact systemStep_other_node_eq different systemStep - -theorem next_sent_extends - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - exists added, after.sent = before.sent ++ added := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact ⟨retryMessages config source sourceState, rfl⟩ - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - refine ⟨[], ?_⟩ - simp - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - refine ⟨[], ?_⟩ - simp - -theorem next_openings_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall opening, opening ∈ before.openings -> - opening ∈ after.openings := by - intro opening membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_openings_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_openings_recordEffects - simpa using membership - -theorem next_restarts_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall restart, restart ∈ before.restarts -> - restart ∈ after.restarts := by - intro restart membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_restarts_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_restarts_recordEffects - simpa using membership - -theorem next_completed_monotonic - {config : Config} - {before after : State} - {action : Action} - (transition : next config before action = some after) : - forall completed, completed ∈ before.completed -> - completed ∈ after.completed := by - intro completed membership - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact membership - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, rfl⟩ - apply mem_completed_recordEffects - simpa using membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, rfl⟩ - apply mem_completed_recordEffects - simpa using membership - -theorem retry_preserves_well_formed - {config : Config} - {before after : State} - {source : Location} - (wellFormed : WellFormed config before) - (transition : next config before (.retry source) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨sourceActive, sourceState, found, _, stateEq⟩ - have sourceLocation : sourceState.location = source := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - constructor - · exact wellFormed.nodeKeys - · exact wellFormed.nodeKeysNodup - · exact wellFormed.nodeLocations - · exact wellFormed.activeNodup - · exact wellFormed.activeConfigured - · intro envelope membership - rw [List.mem_append] at membership - rcases membership with membership | membership - · exact wellFormed.sentValid envelope membership - · exact retryMessages_valid config source sourceState - sourceLocation envelope membership - · intro envelope membership - rw [List.mem_append] at membership - rcases membership with membership | membership - · exact wellFormed.sentSourceActive envelope membership - · rw [(retryMessages_source membership).1] - exact sourceActive - · intro envelope membership - rw [List.mem_append] at membership ⊢ - rcases membership with membership | membership - · exact Or.inl (wellFormed.networkSent envelope membership) - · exact Or.inr membership - · constructor - · exact wellFormed.historiesActive.openings - · exact wellFormed.historiesActive.restarts - · exact wellFormed.historiesActive.completed - -theorem deliver_preserves_well_formed - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (transition : next config before (.deliver envelope) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, targetActive, system, output, systemStep, stateEq⟩ - rw [←stateEq] - constructor - · simp only [recordEffects_system] - exact (systemStep_node_keys_eq systemStep).trans - wellFormed.nodeKeys - · rw [recordEffects_system, systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · simp only [recordEffects_system] - exact systemStep_preserves_node_locations - wellFormed.nodeLocations systemStep - · simpa using wellFormed.activeNodup - · simpa using wellFormed.activeConfigured - · intro sent membership - rw [recordEffects_sent] at membership - exact wellFormed.sentValid sent membership - · intro sent membership - rw [recordEffects_sent] at membership - rw [recordEffects_active] - exact wellFormed.sentSourceActive sent membership - · intro pending membership - rw [recordEffects_network] at membership - rw [recordEffects_sent] - exact wellFormed.networkSent pending - (mem_of_mem_removeOne envelope pending before.network membership) - · apply recordEffects_preserves_histories_active - · constructor - · simpa using wellFormed.historiesActive.openings - · simpa using wellFormed.historiesActive.restarts - · simpa using wellFormed.historiesActive.completed - · simpa using targetActive - -theorem timeout_preserves_well_formed - {config : Config} - {before after : State} - {target : Location} - (wellFormed : WellFormed config before) - (transition : next config before (.timeout target) = some after) : - WellFormed config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨targetActive, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - constructor - · simp only [recordEffects_system] - exact (systemStep_node_keys_eq systemStep).trans - wellFormed.nodeKeys - · rw [recordEffects_system, systemStep_node_keys_eq systemStep] - exact wellFormed.nodeKeysNodup - · simp only [recordEffects_system] - exact systemStep_preserves_node_locations - wellFormed.nodeLocations systemStep - · simpa using wellFormed.activeNodup - · simpa using wellFormed.activeConfigured - · intro sent membership - rw [recordEffects_sent] at membership - exact wellFormed.sentValid sent membership - · intro sent membership - rw [recordEffects_sent] at membership - rw [recordEffects_active] - exact wellFormed.sentSourceActive sent membership - · intro pending membership - rw [recordEffects_network] at membership - rw [recordEffects_sent] - exact wellFormed.networkSent pending membership - · apply recordEffects_preserves_histories_active - · constructor - · simpa using wellFormed.historiesActive.openings - · simpa using wellFormed.historiesActive.restarts - · simpa using wellFormed.historiesActive.completed - · simpa using targetActive - -theorem next_preserves_well_formed - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (transition : next config before action = some after) : - WellFormed config after := by - cases action with - | retry source => - exact retry_preserves_well_formed wellFormed transition - | deliver envelope => - exact deliver_preserves_well_formed wellFormed transition - | timeout target => - exact timeout_preserves_well_formed wellFormed transition - -theorem reachable_well_formed - {config : Config} - {state : State} - (reachable : Reachable config state) : - WellFormed config state := by - induction reachable with - | initial active valid nodup configured => - exact initial_well_formed config active valid nodup configured - | step reachable transition wellFormed => - exact next_preserves_well_formed wellFormed transition - -theorem reachable_config_valid - {config : Config} - {state : State} - (reachable : Reachable config state) : - config.Valid := by - induction reachable with - | initial active valid nodup configured => exact valid - | step reachable transition valid => exact valid - end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean index 7413f3f435e..8dd4f36170d 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Quorum.lean @@ -1,5 +1,6 @@ import DisasterRecovery.Protocol.Invariants -import Mathlib.Tactic + +/-! Human-reviewed vote provenance, quorum and opening predicates. -/ namespace DisasterRecovery.Protocol.Global @@ -77,1391 +78,14 @@ structure QuorumInvariant (config : Config) (state : State) : Prop where sentVotesSelected : SentVotesSelected state openingsValid : OpeningsValid config state -theorem insertVote_nodup - (source : Location) - {votes : List Location} - (nodup : votes.Nodup) : - (insertVote source votes).Nodup := by - unfold insertVote - split - · exact nodup - · rename_i absent - apply (List.mergeSort_perm _ _).symm.nodup - rw [List.nodup_cons] - exact - ⟨fun member => absent (List.contains_iff_mem.mpr member), nodup⟩ - -theorem mem_insertVote - {member source : Location} - {votes : List Location} - (membership : member ∈ insertVote source votes) : - member ∈ votes \/ member = source := by - unfold insertVote at membership - split at membership - · exact Or.inl membership - · have unsorted := - (List.mergeSort_perm _ _).mem_iff.mp membership - rw [List.mem_cons] at unsorted - exact unsorted.symm - -theorem step_preserves_votes_nodup - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (nodup : state.votes.Nodup) : - (step config state event).state.votes.Nodup := by - cases event <;> - simp [step, rejected, advance, advanceTimeoutLane] - all_goals - repeat first | split | simp_all [insertVote_nodup] - def acceptedVoteSource : Event -> Option Location | .receiveVote source .accepted => some source | _ => none -theorem step_votes_shape - (config : Protocol.Config) - (state : NodeState) - (event : Event) : - (step config state event).state.votes = state.votes \/ - exists source, - acceptedVoteSource event = some source /\ - (step config state event).state.votes = - insertVote source state.votes := by - cases event - all_goals try cases_type Validation - all_goals - simp [acceptedVoteSource, step, rejected, advance, advanceTimeoutLane] - all_goals repeat first | split | simp_all - -theorem step_vote_origin - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (voter : Location) - (membership : voter ∈ (step config state event).state.votes) : - voter ∈ state.votes \/ - acceptedVoteSource event = some voter := by - rcases step_votes_shape config state event with - unchanged | ⟨source, sourceEq, changed⟩ - · rw [unchanged] at membership - exact Or.inl membership - · rw [changed] at membership - rcases mem_insertVote membership with old | added - · exact Or.inl old - · subst source - exact Or.inr sourceEq - -theorem step_preserves_non_gossiping - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (pastGossip : state.phase ≠ .gossiping) : - (step config state event).state.phase ≠ .gossiping := by - cases event <;> - simp [step, rejected, advance, advanceTimeoutLane] - all_goals repeat first | split | simp_all - -theorem voting_step_preserves_choice - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (pastGossip : state.phase ≠ .gossiping) - (stillVoting : (step config state event).state.phase = .voting) : - state.phase = .voting /\ - (step config state event).state.chosen = state.chosen := by - cases event <;> - simp [step, rejected, advance, advanceTimeoutLane] at stillVoting ⊢ - all_goals repeat first | split at stillVoting | split | simp_all - -theorem step_preserves_voting_selection - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (before : - state.phase = .voting -> - NodeVotingSelection state) - (voting : (step config state event).state.phase = .voting) : - NodeVotingSelection (step config state event).state := by - cases event - all_goals try cases_type Validation - all_goals - simp [NodeVotingSelection, step, rejected, advance, - advanceTimeoutLane, validTimeout] at before voting ⊢ - all_goals - repeat first | split at voting | split | simp_all | aesop - -theorem retry_vote_state - {config : Config} - {envelope : Envelope} - (valid : envelope.Valid config) - (vote : envelope.payload = .vote) : - envelope.sourceState.phase = .voting /\ - envelope.sourceState.chosen = some envelope.target := by - rcases valid_envelope_effect valid with - ⟨effect, member, created⟩ - cases effect with - | sendGossip target => - cases found : recoveredTxID config envelope.source with - | none => - simp [messageForEffect, found] at created - | some txid => - simp [messageForEffect, found] at created - rw [←created] at vote - contradiction - | sendVote target => - simp [messageForEffect] at created - rw [←created] at vote ⊢ - cases phase : envelope.sourceState.phase <;> - simp [step, phase] at member - next => - cases chosen : envelope.sourceState.chosen <;> - simp_all - | sendIAmOpen target => - simp [messageForEffect] at created - rw [←created] at vote - contradiction - | opening kind => - simp [messageForEffect] at created - | restart chosen => - simp [messageForEffect] at created - | completed => - simp [messageForEffect] at created - | rejected reason => - simp [messageForEffect] at created - -theorem opening_effect_state - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (kind : OpenKind) - (opening : .opening kind ∈ (step config state event).effects) : - (step config state event).state.phase = .opening /\ - (step config state event).state.openKind = some kind := by - cases event - all_goals try cases_type Validation - all_goals - simp [step, rejected, advance, advanceTimeoutLane, validTimeout] - at opening ⊢ - all_goals - repeat first | split at opening | split | simp_all | aesop - -theorem quorum_effect_has_threshold - (config : Protocol.Config) - (state : NodeState) - (event : Event) - (opening : - .opening .quorum ∈ (step config state event).effects) : - voteQuorum config <= - (step config state event).state.votes.length := by - cases event - all_goals try cases_type Validation - all_goals - simp [step, rejected, advance, advanceTimeoutLane, validTimeout] - at opening ⊢ - all_goals - repeat first | split at opening | split | simp_all | aesop - -theorem sentVote_mono - {before after : State} - {voter target : Location} - (sent : forall envelope, envelope ∈ before.sent -> - envelope ∈ after.sent) - (vote : SentVote before voter target) : - SentVote after voter target := by - rcases vote with - ⟨envelope, membership, source, destination, payload⟩ - exact - ⟨envelope, sent envelope membership, source, destination, payload⟩ - -theorem opening_valid_of_sent_eq - {config : Config} - {before after : State} - {opening : Opening} - (sentEq : after.sent = before.sent) - (valid : opening.Valid config before) : - opening.Valid config after := by - rcases valid with - ⟨location, phase, kind, nodup, quorum, votesSent⟩ - constructor - · exact location - · exact phase - · exact kind - · exact nodup - · exact quorum - · intro voter membership - apply sentVote_mono - · intro envelope sent - rw [sentEq] - exact sent - · exact votesSent voter membership - -theorem opening_valid_mono - {config : Config} - {before after : State} - {opening : Opening} - (sent : - forall envelope, envelope ∈ before.sent -> - envelope ∈ after.sent) - (valid : opening.Valid config before) : - opening.Valid config after := by - rcases valid with - ⟨location, phase, kind, nodup, quorum, votesSent⟩ - constructor - · exact location - · exact phase - · exact kind - · exact nodup - · exact quorum - · intro voter membership - exact sentVote_mono sent (votesSent voter membership) - -theorem recordEffect_preserves_openings_valid - {config : Config} - {node : Location} - {nodeState : NodeState} - {state : State} - {effect : Effect} - (valid : OpeningsValid config state) - (newValid : - forall kind, - effect = .opening kind -> - Opening.Valid config state - { node, kind, state := nodeState }) : - OpeningsValid config - (recordEffect node nodeState state effect) := by - intro opening membership - cases effect with - | opening kind => - simp [recordEffect] at membership - rcases membership with rfl | old - · apply opening_valid_of_sent_eq - (before := state) - (after := recordEffect node nodeState state (.opening kind)) - rfl - exact newValid kind rfl - · apply opening_valid_of_sent_eq - (before := state) - (after := recordEffect node nodeState state (.opening kind)) - rfl - exact valid opening old - | sendGossip target => - exact valid opening membership - | sendVote target => - exact valid opening membership - | sendIAmOpen target => - exact valid opening membership - | restart target => - apply opening_valid_of_sent_eq - (before := state) - (after := recordEffect node nodeState state (.restart target)) - rfl - exact valid opening membership - | completed => - apply opening_valid_of_sent_eq - (before := state) - (after := recordEffect node nodeState state .completed) - rfl - exact valid opening membership - | rejected reason => - exact valid opening membership - -theorem recordEffects_preserves_openings_valid - {config : Config} - {node : Location} - {nodeState : NodeState} - {state : State} - {effects : List Effect} - (valid : OpeningsValid config state) - (newValid : - forall kind, - .opening kind ∈ effects -> - Opening.Valid config state - { node, kind, state := nodeState }) : - OpeningsValid config - (recordEffects node nodeState effects state) := by - induction effects generalizing state with - | nil => exact valid - | cons effect tail ih => - simp only [recordEffects, List.foldl_cons] - apply ih - · apply recordEffect_preserves_openings_valid valid - intro kind effectEq - subst effect - exact newValid kind (by simp) - · intro kind membership - apply opening_valid_of_sent_eq - (before := state) - (after := recordEffect node nodeState state effect) - (by cases effect <;> rfl) - exact newValid kind (by simp [membership]) - -theorem eventFor_vote_source - {envelope : Envelope} - {voter : Location} - (source : - acceptedVoteSource (eventFor envelope) = some voter) : - envelope.payload = .vote /\ - envelope.source = voter := by - cases payload : envelope.payload <;> - simp_all [eventFor, acceptedVoteSource] - -theorem systemStep_preserves_votes_nodup - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (nodup : - forall entry, entry ∈ before.nodes -> - entry.2.votes.Nodup) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.votes.Nodup := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, stateEq, _⟩ - rw [←stateEq] - intro entry membership - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · apply step_preserves_votes_nodup - exact nodup (key, node) (List.mem_of_find?_eq_some found) - · exact nodup previous previousMember - -theorem systemStep_preserves_voting_selections - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (valid : - forall entry, entry ∈ before.nodes -> - entry.2.phase = .voting -> - NodeVotingSelection entry.2) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.2.phase = .voting -> - NodeVotingSelection entry.2 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership voting - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · rename_i atTarget - apply step_preserves_voting_selection config node event - · exact valid (key, node) - (List.mem_of_find?_eq_some found) - · simpa [atTarget, outputEq] using voting - · rename_i notTarget - exact valid previous previousMember - (by simpa [notTarget] using voting) - -theorem systemStep_output_location - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (locations : - forall entry, entry ∈ before.nodes -> - entry.2.location = entry.1) - (transition : - systemStep config before target event = some (after, output)) : - output.state.location = target := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, _, outputEq⟩ - calc - output.state.location = - node.location := by - rw [←outputEq] - exact step_preserves_location config node event - _ = key := - locations (key, node) (List.mem_of_find?_eq_some found) - _ = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - -theorem systemStep_output_mem - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (transition : - systemStep config before target event = some (after, output)) : - (target, output.state) ∈ after.nodes := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq, replaceNode, List.mem_map] - refine ⟨(key, node), List.mem_of_find?_eq_some found, ?_⟩ - have keyEq : key = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - simp [keyEq, outputEq] - -theorem systemStep_opening_effect_state - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {kind : OpenKind} - (transition : - systemStep config before target event = some (after, output)) - (opening : .opening kind ∈ output.effects) : - output.state.phase = .opening /\ - output.state.openKind = some kind := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, _, _, outputEq⟩ - rw [←outputEq] at opening ⊢ - exact opening_effect_state config node event kind opening - -theorem systemStep_quorum_effect_has_threshold - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - (transition : - systemStep config before target event = some (after, output)) - (opening : .opening .quorum ∈ output.effects) : - voteQuorum config <= output.state.votes.length := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, _, _, outputEq⟩ - rw [←outputEq] at opening ⊢ - exact quorum_effect_has_threshold config node event opening - -theorem initial_node_votes_nodup - (config : Config) - (active : List Location) : - NodeVotesNodup (initial config active) := by - simp [NodeVotesNodup, Global.initial, initialSystem, initialNode] - -theorem initial_node_votes_sent - (config : Config) - (active : List Location) : - NodeVotesSent (initial config active) := by - simp [NodeVotesSent, Global.initial, initialSystem, initialNode] - -theorem initial_sent_votes_functional - (config : Config) - (active : List Location) : - SentVotesFunctional (initial config active) := by - simp [SentVotesFunctional, SentVote, Global.initial] - -theorem initial_sent_vote_stable - (config : Config) - (active : List Location) : - SentVoteStable (initial config active) := by - simp [SentVoteStable, Global.initial] - -theorem initial_voting_selections - (config : Config) - (active : List Location) : - VotingSelectionsValid (initial config active) := by - simp [VotingSelectionsValid, Global.initial, initialSystem, initialNode] - -theorem initial_sent_votes_selected - (config : Config) - (active : List Location) : - SentVotesSelected (initial config active) := by - simp [SentVotesSelected, Global.initial] - -theorem initial_openings_valid - (config : Config) - (active : List Location) : - OpeningsValid config (initial config active) := by - simp [OpeningsValid, Global.initial] - -theorem systemStep_preserves_node_votes_sent - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {beforeState afterState : State} - (beforeSystem : beforeState.system = before) - (votesSent : NodeVotesSent beforeState) - (carry : - forall voter destination, - SentVote beforeState voter destination -> - SentVote afterState voter destination) - (introduced : - forall voter, - acceptedVoteSource event = some voter -> - SentVote afterState voter target) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - forall voter, voter ∈ entry.2.votes -> - SentVote afterState voter entry.1 := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership voter vote - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · rename_i atTarget - have targetEq : previous.1 = target := - beq_iff_eq.mp atTarget - rcases step_vote_origin config node event voter - (by simpa [outputEq, atTarget] using vote) with - old | added - · have keyEq : key = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - apply carry - rw [←keyEq] - exact votesSent (key, node) - (by - rw [beforeSystem] - exact List.mem_of_find?_eq_some found) - voter old - · exact introduced voter added - · rename_i notTarget - apply carry - exact votesSent previous - (by - rw [beforeSystem] - exact previousMember) - voter (by simpa [notTarget] using vote) - -theorem eq_of_key_eq - {α : Type} - {nodes : List (Prod Location α)} - (nodup : (nodes.map Prod.fst).Nodup) - {first second : Prod Location α} - (firstMember : first ∈ nodes) - (secondMember : second ∈ nodes) - (keyEq : first.1 = second.1) : - first = second := by - induction nodes generalizing first second with - | nil => simp at firstMember - | cons head tail ih => - rw [List.map_cons, List.nodup_cons] at nodup - rcases nodup with ⟨headFresh, tailNodup⟩ - rw [List.mem_cons] at firstMember secondMember - rcases firstMember with rfl | firstTail - · rcases secondMember with rfl | secondTail - · rfl - · exfalso - apply headFresh - rw [List.mem_map] - exact ⟨second, secondTail, keyEq.symm⟩ - · rcases secondMember with rfl | secondTail - · exfalso - apply headFresh - rw [List.mem_map] - exact ⟨first, firstTail, keyEq⟩ - · exact ih tailNodup firstTail secondTail keyEq - -theorem systemStep_preserves_vote_stability - {config : Protocol.Config} - {before after : SystemState} - {target : Location} - {event : Event} - {output : StepOutput} - {envelope : Envelope} - (stable : - forall entry, entry ∈ before.nodes -> - entry.1 = envelope.source -> - entry.2.phase ≠ .gossiping /\ - (entry.2.phase = .voting -> - entry.2.chosen = some envelope.target)) - (transition : - systemStep config before target event = some (after, output)) : - forall entry, entry ∈ after.nodes -> - entry.1 = envelope.source -> - entry.2.phase ≠ .gossiping /\ - (entry.2.phase = .voting -> - entry.2.chosen = some envelope.target) := by - simp [systemStep, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨node, ⟨key, found⟩, systemEq, outputEq⟩ - rw [←systemEq] - intro entry membership sourceEq - rw [replaceNode, List.mem_map] at membership - rcases membership with ⟨previous, previousMember, rfl⟩ - split - · rename_i atTarget - have targetEq : previous.1 = target := - beq_iff_eq.mp atTarget - have targetSource : target = envelope.source := by - simpa [atTarget] using sourceEq - have keyEq : key = target := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == target) found) - have beforeStable := - stable (key, node) (List.mem_of_find?_eq_some found) - (keyEq.trans targetSource) - constructor - · exact step_preserves_non_gossiping config node event - beforeStable.1 - · intro voting - rcases voting_step_preserves_choice config node event - beforeStable.1 voting with ⟨beforeVoting, chosenEq⟩ - rw [chosenEq] - exact beforeStable.2 beforeVoting - · rename_i notTarget - exact stable previous previousMember - (by simpa [notTarget] using sourceEq) - -theorem next_preserves_node_votes_nodup - {config : Config} - {before after : State} - {action : Action} - (nodup : NodeVotesNodup before) - (transition : next config before action = some after) : - NodeVotesNodup after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact nodup - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, rfl⟩ - intro entry membership - rw [recordEffects_system] at membership - exact systemStep_preserves_votes_nodup nodup systemStep - entry membership - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, rfl⟩ - intro entry membership - rw [recordEffects_system] at membership - exact systemStep_preserves_votes_nodup nodup systemStep - entry membership - -theorem next_preserves_voting_selections - {config : Config} - {before after : State} - {action : Action} - (valid : VotingSelectionsValid before) - (transition : next config before action = some after) : - VotingSelectionsValid after := by - cases action with - | retry source => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - exact valid - | deliver envelope => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, rfl⟩ - intro entry membership voting - rw [recordEffects_system] at membership - exact systemStep_preserves_voting_selections valid systemStep - entry membership voting - | timeout target => - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, rfl⟩ - intro entry membership voting - rw [recordEffects_system] at membership - exact systemStep_preserves_voting_selections valid systemStep - entry membership voting - -theorem retry_preserves_sent_votes_selected - {config : Config} - {before after : State} - {source : Location} - (wellFormed : WellFormed config before) - (votingSelections : VotingSelectionsValid before) - (selected : SentVotesSelected before) - (transition : next config before (.retry source) = some after) : - SentVotesSelected after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, found, _, stateEq⟩ - have sourceLocation : sourceState.location = source := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - intro envelope membership payload - rw [List.mem_append] at membership - rcases membership with old | added - · exact selected envelope old payload - · have valid : envelope.Valid config := - retryMessages_valid config source sourceState sourceLocation - envelope added - have voteState := retry_vote_state valid payload - have identity := retryMessages_source added - rw [identity.2] at voteState - rw [nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have sourceSelection := - votingSelections entry (List.mem_of_find?_eq_some findEq) - (by simpa [stateEq] using voteState.1) - simpa [identity.2, stateEq] using sourceSelection - -theorem deliver_preserves_sent_votes_selected - {config : Config} - {before after : State} - {envelope : Envelope} - (selected : SentVotesSelected before) - (transition : next config before (.deliver envelope) = some after) : - SentVotesSelected after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, stateEq⟩ - rw [←stateEq] - intro vote membership payload - rw [recordEffects_sent] at membership - exact selected vote membership payload - -theorem timeout_preserves_sent_votes_selected - {config : Config} - {before after : State} - {target : Location} - (selected : SentVotesSelected before) - (transition : next config before (.timeout target) = some after) : - SentVotesSelected after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, stateEq⟩ - rw [←stateEq] - intro vote membership payload - rw [recordEffects_sent] at membership - exact selected vote membership payload - -theorem retry_preserves_node_votes_sent - {config : Config} - {before after : State} - {source : Location} - (votesSent : NodeVotesSent before) - (transition : next config before (.retry source) = some after) : - NodeVotesSent after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, rfl⟩ - intro entry membership voter vote - apply sentVote_mono (before := before) - · intro envelope sent - exact List.mem_append_left _ sent - · exact votesSent entry membership voter vote - -theorem deliver_preserves_node_votes_sent - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (votesSent : NodeVotesSent before) - (transition : next config before (.deliver envelope) = some after) : - NodeVotesSent after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨inNetwork, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - intro entry membership voter vote - rw [recordEffects_system] at membership - let afterState := - recordEffects envelope.target output.state output.effects - { - before with - system - network := removeOne envelope before.network - } - have carry : - forall oldVoter oldTarget, - SentVote before oldVoter oldTarget -> - SentVote afterState oldVoter oldTarget := by - intro oldVoter oldTarget oldVote - apply sentVote_mono (before := before) (after := afterState) - · intro sent sentMember - simpa [afterState] using sentMember - · exact oldVote - have introducedVote : - forall newVoter, - acceptedVoteSource (eventFor envelope) = some newVoter -> - SentVote afterState newVoter envelope.target := by - intro newVoter introduced - rcases eventFor_vote_source introduced with - ⟨payload, source⟩ - subst newVoter - refine ⟨envelope, ?_, rfl, rfl, payload⟩ - simp [afterState] - exact wellFormed.networkSent envelope - inNetwork - exact systemStep_preserves_node_votes_sent - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl votesSent carry introducedVote systemStep - entry membership voter vote - -theorem timeout_preserves_node_votes_sent - {config : Config} - {before after : State} - {target : Location} - (votesSent : NodeVotesSent before) - (transition : next config before (.timeout target) = some after) : - NodeVotesSent after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - intro entry membership voter vote - rw [recordEffects_system] at membership - let afterState := - recordEffects target output.state output.effects - { before with system } - have carry : - forall oldVoter oldTarget, - SentVote before oldVoter oldTarget -> - SentVote afterState oldVoter oldTarget := by - intro oldVoter oldTarget oldVote - apply sentVote_mono (before := before) (after := afterState) - · intro sent sentMember - simpa [afterState] using sentMember - · exact oldVote - have introducedVote : - forall newVoter, - acceptedVoteSource Event.timeout = some newVoter -> - SentVote afterState newVoter target := by - intro newVoter introduced - simp [acceptedVoteSource] at introduced - exact systemStep_preserves_node_votes_sent - (before := before.system) - (after := system) - (beforeState := before) - (afterState := afterState) - rfl votesSent carry introducedVote systemStep - entry membership voter vote - -theorem retry_preserves_openings_valid - {config : Config} - {before after : State} - {source : Location} - (valid : OpeningsValid config before) - (transition : next config before (.retry source) = some after) : - OpeningsValid config after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with ⟨_, sourceState, _, _, stateEq⟩ - rw [←stateEq] - intro opening membership - apply opening_valid_mono - · intro envelope sent - exact List.mem_append_left _ sent - · exact valid opening membership - -theorem deliver_preserves_openings_valid - {config : Config} - {before after : State} - {envelope : Envelope} - (wellFormed : WellFormed config before) - (votesNodup : NodeVotesNodup before) - (votesSent : NodeVotesSent before) - (valid : OpeningsValid config before) - (transition : next config before (.deliver envelope) = some after) : - OpeningsValid config after := by - have afterNodup := - next_preserves_node_votes_nodup votesNodup transition - have afterVotesSent := - deliver_preserves_node_votes_sent wellFormed votesSent transition - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] at afterNodup afterVotesSent ⊢ - let delivered : State := { - before with - system - network := removeOne envelope before.network - } - apply recordEffects_preserves_openings_valid - · intro opening membership - apply opening_valid_of_sent_eq - (before := before) (after := delivered) rfl - exact valid opening membership - · intro kind openingEffect - have effectState := - systemStep_opening_effect_state systemStep openingEffect - constructor - · exact systemStep_output_location - wellFormed.nodeLocations systemStep - · exact effectState.1 - · exact effectState.2 - · apply afterNodup (envelope.target, output.state) - rw [recordEffects_system] - exact systemStep_output_mem systemStep - · intro quorumKind - have kindEq : kind = .quorum := by simpa using quorumKind - rw [kindEq] at openingEffect - simpa using - systemStep_quorum_effect_has_threshold systemStep openingEffect - · intro voter vote - have sent := - afterVotesSent (envelope.target, output.state) - (by - rw [recordEffects_system] - exact systemStep_output_mem systemStep) - voter vote - simpa [SentVote, delivered] using sent - -theorem timeout_preserves_openings_valid - {config : Config} - {before after : State} - {target : Location} - (wellFormed : WellFormed config before) - (votesNodup : NodeVotesNodup before) - (votesSent : NodeVotesSent before) - (valid : OpeningsValid config before) - (transition : next config before (.timeout target) = some after) : - OpeningsValid config after := by - have afterNodup := - next_preserves_node_votes_nodup votesNodup transition - have afterVotesSent := - timeout_preserves_node_votes_sent votesSent transition - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] at afterNodup afterVotesSent ⊢ - let timedOut : State := { before with system } - apply recordEffects_preserves_openings_valid - · intro opening membership - apply opening_valid_of_sent_eq - (before := before) (after := timedOut) rfl - exact valid opening membership - · intro kind openingEffect - have effectState := - systemStep_opening_effect_state systemStep openingEffect - constructor - · exact systemStep_output_location - wellFormed.nodeLocations systemStep - · exact effectState.1 - · exact effectState.2 - · apply afterNodup (target, output.state) - rw [recordEffects_system] - exact systemStep_output_mem systemStep - · intro quorumKind - have kindEq : kind = .quorum := by simpa using quorumKind - rw [kindEq] at openingEffect - simpa using - systemStep_quorum_effect_has_threshold systemStep openingEffect - · intro voter vote - have sent := - afterVotesSent (target, output.state) - (by - rw [recordEffects_system] - exact systemStep_output_mem systemStep) - voter vote - simpa [SentVote, timedOut] using sent - -theorem retry_preserves_sent_vote_stable - {config : Config} - {before after : State} - {source : Location} - (wellFormed : WellFormed config before) - (stable : SentVoteStable before) - (transition : next config before (.retry source) = some after) : - SentVoteStable after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, found, _, stateEq⟩ - have sourceLocation : sourceState.location = source := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - intro envelope membership payload entry entryMember keyEq - rw [List.mem_append] at membership - rcases membership with old | added - · exact stable envelope old payload entry entryMember keyEq - · have valid : envelope.Valid config := - retryMessages_valid config source sourceState sourceLocation - envelope added - have voteState := retry_vote_state valid payload - rcases retryMessages_source added with - ⟨sourceEq, stateEq⟩ - rw [nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨foundEntry, findEq, foundStateEq⟩ - have foundMember : foundEntry ∈ before.system.nodes := - List.mem_of_find?_eq_some findEq - have foundKey : foundEntry.1 = source := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == source) findEq) - have sameEntry : entry = foundEntry := - eq_of_key_eq wellFormed.nodeKeysNodup entryMember foundMember - ((keyEq.trans sourceEq).trans foundKey.symm) - subst entry - rw [foundStateEq, ←stateEq] - exact ⟨by simp [voteState.1], fun _ => voteState.2⟩ - -theorem deliver_preserves_sent_vote_stable - {config : Config} - {before after : State} - {delivered : Envelope} - (stable : SentVoteStable before) - (transition : next config before (.deliver delivered) = some after) : - SentVoteStable after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, systemStep, stateEq⟩ - rw [←stateEq] - intro envelope membership payload entry entryMember keyEq - rw [recordEffects_sent] at membership - rw [recordEffects_system] at entryMember - exact systemStep_preserves_vote_stability - (fun previous previousMember source => - stable envelope membership payload previous previousMember source) - systemStep entry entryMember keyEq - -theorem timeout_preserves_sent_vote_stable - {config : Config} - {before after : State} - {target : Location} - (stable : SentVoteStable before) - (transition : next config before (.timeout target) = some after) : - SentVoteStable after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, systemStep, _, stateEq⟩ - rw [←stateEq] - intro envelope membership payload entry entryMember keyEq - rw [recordEffects_sent] at membership - rw [recordEffects_system] at entryMember - exact systemStep_preserves_vote_stability - (fun previous previousMember source => - stable envelope membership payload previous previousMember source) - systemStep entry entryMember keyEq - -theorem sentVote_stable_at_node - {state : State} - {voter target : Location} - {current : NodeState} - (stable : SentVoteStable state) - (vote : SentVote state voter target) - (found : nodeState state voter = some current) : - current.phase ≠ .gossiping /\ - (current.phase = .voting -> - current.chosen = some target) := by - rcases vote with - ⟨envelope, sent, sourceEq, targetEq, payload⟩ - rw [nodeState, Option.map_eq_some_iff] at found - rcases found with ⟨entry, findEq, stateEq⟩ - have entryMember : entry ∈ state.system.nodes := - List.mem_of_find?_eq_some findEq - have entryKey : entry.1 = voter := - beq_iff_eq.mp - (List.find?_some - (p := fun entry : Prod Location NodeState => - entry.1 == voter) findEq) - have result := - stable envelope sent payload entry entryMember - (entryKey.trans sourceEq.symm) - rw [stateEq] at result - simpa [targetEq] using result - -theorem retry_preserves_sent_votes_functional - {config : Config} - {before after : State} - {source : Location} - (wellFormed : WellFormed config before) - (functional : SentVotesFunctional before) - (stable : SentVoteStable before) - (transition : next config before (.retry source) = some after) : - SentVotesFunctional after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, sourceState, found, _, stateEq⟩ - have sourceLocation : sourceState.location = source := - nodeState_location wellFormed.nodeLocations found - rw [←stateEq] - have classify : - forall voter target, - SentVote - { - before with - network := before.network ++ - retryMessages config source sourceState - sent := before.sent ++ - retryMessages config source sourceState - } - voter target -> - SentVote before voter target \/ - (voter = source /\ - sourceState.phase = .voting /\ - sourceState.chosen = some target) := by - intro voter target vote - rcases vote with - ⟨envelope, membership, sourceEq, targetEq, payload⟩ - rw [List.mem_append] at membership - rcases membership with old | added - · exact Or.inl - ⟨envelope, old, sourceEq, targetEq, payload⟩ - · have valid : envelope.Valid config := - retryMessages_valid config source sourceState sourceLocation - envelope added - have voteState := retry_vote_state valid payload - have retryIdentity := retryMessages_source added - rw [retryIdentity.2] at voteState - exact Or.inr - ⟨sourceEq.symm.trans retryIdentity.1, - voteState.1, - by simpa [targetEq] using voteState.2⟩ - intro voter first second firstVote secondVote - rcases classify voter first firstVote with - firstOld | ⟨firstSource, firstPhase, firstChoice⟩ - · rcases classify voter second secondVote with - secondOld | ⟨secondSource, secondPhase, secondChoice⟩ - · exact functional voter first second firstOld secondOld - · have oldState := - sentVote_stable_at_node stable firstOld - (by simpa [secondSource] using found) - have oldChoice := oldState.2 secondPhase - rw [oldChoice] at secondChoice - exact Option.some.inj secondChoice - · rcases classify voter second secondVote with - secondOld | ⟨secondSource, secondPhase, secondChoice⟩ - · have oldState := - sentVote_stable_at_node stable secondOld - (by simpa [firstSource] using found) - have oldChoice := oldState.2 firstPhase - rw [oldChoice] at firstChoice - exact (Option.some.inj firstChoice).symm - · rw [firstChoice] at secondChoice - exact Option.some.inj secondChoice - -theorem deliver_preserves_sent_votes_functional - {config : Config} - {before after : State} - {envelope : Envelope} - (functional : SentVotesFunctional before) - (transition : next config before (.deliver envelope) = some after) : - SentVotesFunctional after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, _, system, output, _, stateEq⟩ - rw [←stateEq] - intro voter first second firstVote secondVote - apply functional voter first second - · simpa [SentVote] using firstVote - · simpa [SentVote] using secondVote - -theorem timeout_preserves_sent_votes_functional - {config : Config} - {before after : State} - {target : Location} - (functional : SentVotesFunctional before) - (transition : next config before (.timeout target) = some after) : - SentVotesFunctional after := by - simp [next, Option.bind_eq_some_iff] at transition - rcases transition with - ⟨_, system, output, _, _, stateEq⟩ - rw [←stateEq] - intro voter first second firstVote secondVote - apply functional voter first second - · simpa [SentVote] using firstVote - · simpa [SentVote] using secondVote - -theorem initial_quorum_invariant - (config : Config) - (active : List Location) : - QuorumInvariant config (initial config active) := { - votesNodup := initial_node_votes_nodup config active - votesSent := initial_node_votes_sent config active - sentVoteStable := initial_sent_vote_stable config active - sentVotesFunctional := initial_sent_votes_functional config active - votingSelections := initial_voting_selections config active - sentVotesSelected := initial_sent_votes_selected config active - openingsValid := initial_openings_valid config active -} - -theorem next_preserves_quorum_invariant - {config : Config} - {before after : State} - {action : Action} - (wellFormed : WellFormed config before) - (invariant : QuorumInvariant config before) - (transition : next config before action = some after) : - QuorumInvariant config after := by - cases action with - | retry source => - constructor - · exact next_preserves_node_votes_nodup - invariant.votesNodup transition - · exact retry_preserves_node_votes_sent - invariant.votesSent transition - · exact retry_preserves_sent_vote_stable - wellFormed invariant.sentVoteStable transition - · exact retry_preserves_sent_votes_functional - wellFormed invariant.sentVotesFunctional - invariant.sentVoteStable transition - · exact next_preserves_voting_selections - invariant.votingSelections transition - · exact retry_preserves_sent_votes_selected - wellFormed invariant.votingSelections - invariant.sentVotesSelected transition - · exact retry_preserves_openings_valid - invariant.openingsValid transition - | deliver envelope => - constructor - · exact next_preserves_node_votes_nodup - invariant.votesNodup transition - · exact deliver_preserves_node_votes_sent - wellFormed invariant.votesSent transition - · exact deliver_preserves_sent_vote_stable - invariant.sentVoteStable transition - · exact deliver_preserves_sent_votes_functional - invariant.sentVotesFunctional transition - · exact next_preserves_voting_selections - invariant.votingSelections transition - · exact deliver_preserves_sent_votes_selected - invariant.sentVotesSelected transition - · exact deliver_preserves_openings_valid - wellFormed invariant.votesNodup invariant.votesSent - invariant.openingsValid transition - | timeout target => - constructor - · exact next_preserves_node_votes_nodup - invariant.votesNodup transition - · exact timeout_preserves_node_votes_sent - invariant.votesSent transition - · exact timeout_preserves_sent_vote_stable - invariant.sentVoteStable transition - · exact timeout_preserves_sent_votes_functional - invariant.sentVotesFunctional transition - · exact next_preserves_voting_selections - invariant.votingSelections transition - · exact timeout_preserves_sent_votes_selected - invariant.sentVotesSelected transition - · exact timeout_preserves_openings_valid - wellFormed invariant.votesNodup invariant.votesSent - invariant.openingsValid transition - -theorem reachable_quorum_invariant - {config : Config} - {state : State} - (reachable : Reachable config state) : - QuorumInvariant config state := by - induction reachable with - | initial active valid nodup configured => - exact initial_quorum_invariant config active - | step reachable transition invariant => - exact next_preserves_quorum_invariant - (reachable_well_formed reachable) invariant transition - -theorem quorum_lists_intersect - {α : Type} - [DecidableEq α] - (expected first second : List α) - (firstNodup : first.Nodup) - (secondNodup : second.Nodup) - (firstSubset : - forall value, value ∈ first -> value ∈ expected) - (secondSubset : - forall value, value ∈ second -> value ∈ expected) - (firstQuorum : - expected.length / 2 + 1 <= first.length) - (secondQuorum : - expected.length / 2 + 1 <= second.length) : - exists value, value ∈ first /\ value ∈ second := by - by_contra noShared - push_neg at noShared - have disjoint : Disjoint first.toFinset second.toFinset := - Finset.disjoint_left.mpr (by - intro value firstMember secondMember - exact noShared value - (List.mem_toFinset.mp firstMember) - (List.mem_toFinset.mp secondMember)) - have unionSubset : - first.toFinset ∪ second.toFinset ⊆ expected.toFinset := by - intro value membership - rw [Finset.mem_union] at membership - rw [List.mem_toFinset] - exact membership.elim - (fun member => - firstSubset value (List.mem_toFinset.mp member)) - (fun member => - secondSubset value (List.mem_toFinset.mp member)) - have unionCard := Finset.card_le_card unionSubset - rw [Finset.card_union_of_disjoint disjoint, - List.toFinset_card_of_nodup firstNodup, - List.toFinset_card_of_nodup secondNodup] at unionCard - have expectedCard := List.toFinset_card_le expected - omega - def QuorumOpened (state : State) (node : Location) : Prop := exists opening, opening ∈ state.openings /\ opening.node = node /\ opening.kind = .quorum -theorem opening_vote_configured - {config : Config} - {state : State} - {opening : Opening} - (wellFormed : WellFormed config state) - (valid : opening.Valid config state) - {voter : Location} - (vote : voter ∈ opening.state.votes) : - voter ∈ config.protocol.expectedLocations := by - rcases valid.votesSent voter vote with - ⟨envelope, sent, sourceEq, _, _⟩ - apply wellFormed.activeConfigured voter - simpa [sourceEq] using - wellFormed.sentSourceActive envelope sent - -theorem quorum_opener_unique - {config : Config} - {state : State} - {first second : Location} - (reachable : Reachable config state) - (firstOpened : QuorumOpened state first) - (secondOpened : QuorumOpened state second) : - first = second := by - have wellFormed := reachable_well_formed reachable - have invariant := reachable_quorum_invariant reachable - rcases firstOpened with - ⟨firstOpening, firstMember, firstNode, firstKind⟩ - rcases secondOpened with - ⟨secondOpening, secondMember, secondNode, secondKind⟩ - have firstValid := - invariant.openingsValid firstOpening firstMember - have secondValid := - invariant.openingsValid secondOpening secondMember - rcases quorum_lists_intersect - config.protocol.expectedLocations - firstOpening.state.votes - secondOpening.state.votes - firstValid.votesNodup - secondValid.votesNodup - (fun voter vote => - opening_vote_configured wellFormed firstValid vote) - (fun voter vote => - opening_vote_configured wellFormed secondValid vote) - (by - simpa [voteQuorum] using firstValid.quorum firstKind) - (by - simpa [voteQuorum] using secondValid.quorum secondKind) with - ⟨voter, firstVote, secondVote⟩ - have targetEq := - invariant.sentVotesFunctional voter - firstOpening.node secondOpening.node - (firstValid.votesSent voter firstVote) - (secondValid.votesSent voter secondVote) - exact firstNode.symm.trans (targetEq.trans secondNode) - end DisasterRecovery.Protocol.Global diff --git a/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean b/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean index 72db88bcbc0..ce028d217ed 100644 --- a/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean +++ b/lean/disaster-recovery/DisasterRecovery/Protocol/Temporal.lean @@ -1,5 +1,7 @@ import DisasterRecovery.Protocol.Model +/-! Human-reviewed local execution and fairness definitions. -/ + namespace DisasterRecovery.Protocol def EventuallyFrom (start : Nat) (predicate : Nat -> Prop) : Prop := @@ -42,190 +44,4 @@ def StrongFairness def AlignedOpening (state : NodeState) : Prop := state.phase = .opening /\ state.timeoutState = .opening -theorem valid_timeout_requires_alignment - (state : NodeState) - (h : validTimeout state true = true) : - state.phase = state.timeoutState := by - simpa [validTimeout] using h - -theorem gossip_freezes_after_choice - (config : Config) - (state : NodeState) - (source : Location) - (txid : TxID) - (h : state.chosen.isSome = true) : - let output := step config state (.receiveGossip source txid .accepted) - output.state = state /\ output.accepted = false := by - cases chosen : state.chosen <;> simp_all [step, rejected] - -theorem rejected_gossip_stutters - (config : Config) - (state : NodeState) - (source : Location) - (txid : TxID) : - let output := step config state (.receiveGossip source txid .rejected) - output.state = state /\ output.accepted = false := by - simp [step, rejected] - -theorem duplicate_vote_is_idempotent - (source : Location) - (votes : List Location) - (h : votes.contains source = true) : - insertVote source votes = votes := by - unfold insertVote - rw [h] - simp - -theorem opening_rejects_iamopen - (config : Config) - (state : NodeState) - (source : Location) : - let opening := { state with phase := .opening } - let output := step config opening (.receiveIAmOpen source .accepted) - output.state = opening /\ output.accepted = false := by - simp [step, rejected] - -theorem open_rejects_iamopen - (config : Config) - (state : NodeState) - (source : Location) : - let opened := { state with phase := .open } - let output := step config opened (.receiveIAmOpen source .accepted) - output.state = opened /\ output.accepted = false := by - simp [step, rejected] - -theorem aligned_voting_timeout_without_votes_stutters - (config : Config) - (state : NodeState) : - let waiting := { - state with - phase := .voting - timeoutState := .voting - votes := [] - } - step config waiting .timeout = { state := waiting } := by - simp [step, advance, validTimeout, voteQuorum] - -theorem aligned_opening_timeout_completes - (config : Config) - (state : NodeState) : - let opening := { - state with - phase := .opening - timeoutState := .opening - } - let output := step config opening .timeout - output.state.phase = .open /\ - output.state.timeoutState = .opening /\ - output.effects = [.completed] := by - simp [step, advance, validTimeout, advanceTimeoutLane, advanceTimeoutState] - -theorem quorum_advance_opens - (config : Config) - (state : NodeState) - (phase : state.phase = .voting) - (quorum : state.votes.length >= voteQuorum config) : - let output := (advance config state false).get! - output.state.phase = .opening /\ - output.state.openKind = some .quorum /\ - output.effects = [.opening .quorum] := by - simp [advance, phase, quorum, validTimeout, advanceTimeoutLane] - -theorem aligned_empty_gossip_timeout_aborts - (config : Config) - (state : NodeState) : - let waiting := { - state with - phase := .gossiping - timeoutState := .gossiping - gossips := [] - } - let output := step config waiting .timeout - output.state = waiting /\ output.accepted = false := by - simp [step, advance, validTimeout, rejected, maximumGossip] - -theorem non_timeout_step_preserves_aligned_opening - (config : Config) - (state : NodeState) - (event : Event) - (aligned : AlignedOpening state) - (notTimeout : Not (event = .timeout)) : - AlignedOpening (step config state event).state := by - have phase := aligned.1 - have timeoutState := aligned.2 - cases event with - | receiveGossip source txid validation => - cases validation <;> - simp_all [AlignedOpening, step, rejected, advance, validTimeout, - advanceTimeoutLane] - split <;> simp_all - | receiveVote source validation => - cases validation <;> - simp_all [AlignedOpening, step, rejected, advance, validTimeout, - advanceTimeoutLane] - | receiveIAmOpen source validation => - cases validation <;> - simp_all [AlignedOpening, step, rejected] - | timeout => - exact (notTimeout rfl).elim - | retry => - simp [AlignedOpening, step, phase, timeoutState] - -theorem aligned_timeout_transitions_to_open - (config : Config) - (state : NodeState) - (aligned : AlignedOpening state) : - (step config state .timeout).state.phase = .open := by - have phase := aligned.1 - have timeoutState := aligned.2 - simp [step, advance, validTimeout, phase, timeoutState, - advanceTimeoutLane, advanceTimeoutState] - -theorem fairness_supplies_firing - {config : Config} - (execution : Execution config) - (enabled : NodeState -> Prop) - (fired : NodeState -> Event -> Prop) - (fair : WeakFairness execution enabled fired) - (alwaysEnabled : forall n, enabled (execution.states n)) : - InfinitelyOften - (fun n => fired (execution.states n) (execution.events n)) := by - intro start - exact fair start (fun n _ => alwaysEnabled n) - -theorem fair_aligned_opening_progress - {config : Config} - (execution : Execution config) - (initial : AlignedOpening (execution.states 0)) - (fair : WeakFairness execution AlignedOpening - (fun _ event => event = .timeout)) : - EventuallyFrom 0 - (fun n => (execution.states n).phase = .open) := by - apply Classical.byContradiction - intro noOpen - have neverOpen : - forall n, Not ((execution.states n).phase = .open) := by - intro n opened - apply noOpen - exact Exists.intro n (And.intro (Nat.zero_le n) opened) - have alignedAlways : forall n, AlignedOpening (execution.states n) := by - intro n - induction n with - | zero => exact initial - | succ n aligned => - have notTimeout : Not (execution.events n = .timeout) := by - intro timeout - apply neverOpen (n + 1) - rw [execution.step_succ n, timeout] - exact aligned_timeout_transitions_to_open config _ aligned - rw [execution.step_succ n] - exact non_timeout_step_preserves_aligned_opening - config _ _ aligned notTimeout - have firing := fair 0 (fun n _ => alignedAlways n) - let n := firing.choose - have timeout := firing.choose_spec.2 - apply neverOpen (n + 1) - rw [execution.step_succ n, timeout] - exact aligned_timeout_transitions_to_open config _ (alignedAlways n) - -end DisasterRecovery.Protocol \ No newline at end of file +end DisasterRecovery.Protocol diff --git a/lean/disaster-recovery/README.md b/lean/disaster-recovery/README.md index 130468ca386..d64dac46ca3 100644 --- a/lean/disaster-recovery/README.md +++ b/lean/disaster-recovery/README.md @@ -27,21 +27,44 @@ discrepancy remains explicit. model receives the result of C++ quote and certificate validation. The model does not formalize or prove the cryptography that produces that result. +## Review guide + +Start with `DisasterRecovery/Properties.lean`: it exposes 15 system-level +`theorem` statements, each with an explicit application of its checked proof. +Review those statements and every definition or assumption they use in +`DisasterRecovery/Protocol/`. Machine checking does not establish that the +model matches the C++ implementation or that its assumptions describe a real +deployment. + +The 233 supporting declarations are `lemma`s in +`DisasterRecovery/Proofs/`. Their implementations can normally be omitted from +line-by-line human review once the build and axiom audit pass. Mathlib's +`lemma` is a synonym for `theorem`, not a weaker form of checking. The existing +helper names are preserved, and the public statements remain explicitly linked +to them rather than being detached specifications. + +Only the Lean files under `DisasterRecovery/Proofs/` are marked +`linguist-generated` in the repository's `.gitattributes`, so GitHub can collapse +them without collapsing the review-required model and properties. Changes to imports, the review boundary, +the toolchain, dependencies, or checking machinery still require human review. +`DisasterRecovery.lean`, `CanonicalTests.lean`, the Lake configuration and lockfile, +and the CI workflow are part of that review surface. + ## Proof coverage and limits -`DisasterRecovery.Protocol.Temporal` proves local safety properties and +`DisasterRecovery.Proofs.Temporal` proves local safety properties and Opening-to-Open progress under weak timeout fairness. -`DisasterRecovery.Protocol.Invariants` proves global well-formedness, +`DisasterRecovery.Proofs.Invariants` proves global well-formedness, message provenance, locality of transitions, append-only send history, and monotonic terminal histories for reachable states. -`DisasterRecovery.Protocol.Quorum` proves that votes are unique and backed by +`DisasterRecovery.Proofs.Quorum` proves that votes are unique and backed by prior sends, strict-majority quorums intersect, and any two quorum openings in a reachable execution select the same opener. This safety result does not require fairness. -`DisasterRecovery.Protocol.Committed` proves TxID maximum properties and +`DisasterRecovery.Proofs.Committed` proves TxID maximum properties and committed-prefix preservation under two explicit premises: - `DurableCommit` requires at least one configured recovered ledger to cover @@ -53,7 +76,7 @@ A quorum opening alone does not imply `FullGossipSelection`, because voting may begin after a gossip timeout. The committed-prefix result deliberately does not derive or hide either durability or full-gossip evidence. -`DisasterRecovery.Protocol.GlobalTemporal` proves conditional global progress. +`DisasterRecovery.Proofs.GlobalTemporal` proves conditional global progress. Its theorems assume the relevant retry, message-delivery, and timeout fairness premises. Progress for every active node additionally requires `BroadcastBeforeCompletion`: an opener must send its `IAmOpen` announcement to @@ -62,19 +85,27 @@ order actions that are enabled only for a finite interval, so this broadcast ordering is a separate premise. The proofs do not construct a scheduler that satisfies the fairness and broadcast-before-completion premises. +The `global_progress` property also requires a reachable initial state and a +nonempty active set. Its terminal outcome means completion or a requested +joining restart. The stronger statements that all other nodes request a restart +retain their explicit `OnlyOpenerCompletesFrom` or `QuorumOnlyCompletions` +premises; they do not rule out failover completions without such a premise. + ## Files -| File | Purpose | -| ----------------------------------------------- | -------------------------------------- | -| `DisasterRecovery/Protocol/Model.lean` | C++-aligned local transition model | -| `DisasterRecovery/Protocol/Temporal.lean` | Local safety and liveness | -| `DisasterRecovery/Protocol/Global.lean` | Distributed transition semantics | -| `DisasterRecovery/Protocol/Invariants.lean` | Reachability invariants | -| `DisasterRecovery/Protocol/Quorum.lean` | Quorum uniqueness | -| `DisasterRecovery/Protocol/Committed.lean` | Committed-prefix safety | -| `DisasterRecovery/Protocol/GlobalTemporal.lean` | Global liveness | -| `CanonicalTests.lean` | Executable canonical behavior checks | -| `AxiomChecks.lean` | Transitive project `sorryAx` rejection | +| File | Review role | Purpose | +| ----------------------------------------------- | --------------- | ---------------------------------------------------- | +| `DisasterRecovery/Properties.lean` | Human | Selected system properties and checked proof links | +| `DisasterRecovery/Protocol/Model.lean` | Human | C++-aligned local transition model | +| `DisasterRecovery/Protocol/Global.lean` | Human | Distributed transitions and reachability | +| `DisasterRecovery/Protocol/Temporal.lean` | Human | Local execution and fairness definitions | +| `DisasterRecovery/Protocol/Invariants.lean` | Human | Well-formedness and message-provenance predicates | +| `DisasterRecovery/Protocol/Quorum.lean` | Human | Vote and quorum-opening predicates | +| `DisasterRecovery/Protocol/Committed.lean` | Human | Prefix ordering, durability and full-gossip premises | +| `DisasterRecovery/Protocol/GlobalTemporal.lean` | Human | Global execution, fairness and termination premises | +| `DisasterRecovery/Proofs/*.lean` | Machine-checked | Supporting lemmas and proof implementations | +| `DisasterRecovery.lean` | Human | Complete library import and audit root | +| `CanonicalTests.lean` | Human | Executable canonical behavior checks | ## Validation @@ -82,7 +113,26 @@ Run from this directory: ```console lake exe cache get -lake build -lake env lean -DwarningAsError=true AxiomChecks.lean +lake exe mk_all --check --lib DisasterRecovery +lake build --wfail +lake lint lake exe canonical-checks ``` + +`lake build --wfail` treats build warnings, including uses of `sorry` and +`admit`, as errors. `lake lint` runs +[`axiom-audit`](https://github.com/leanprover-community/axiom-audit) over the +`DisasterRecovery` library's transitive axiom dependencies. Only `propext`, +`Classical.choice`, and `Quot.sound` are allowed, so `sorryAx`, user-defined +axioms, and `native_decide` dependencies are rejected. + +The build compiles the reviewed statements and their proof implementations; +`lake exe canonical-checks` separately exercises the transition model. +`mk_all --check` verifies that `DisasterRecovery.lean` imports every library +module, preventing newly added proofs from being silently omitted from the +build and audit. Run `lake exe mk_all --lib DisasterRecovery` to refresh the +import root when adding a module. + +When refreshing the auditor dependency, use +`lake --keep-toolchain update axiomAudit` to retain the package's pinned +Lean and Mathlib versions. diff --git a/lean/disaster-recovery/lake-manifest.json b/lean/disaster-recovery/lake-manifest.json index 4df3dace4b3..7eefb7f0600 100644 --- a/lean/disaster-recovery/lake-manifest.json +++ b/lean/disaster-recovery/lake-manifest.json @@ -2,6 +2,18 @@ "version": "1.1.0", "packagesDir": ".lake/packages", "packages": [ + { + "url": "https://github.com/leanprover-community/axiom-audit.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "46024e005996495c65ef609368e11ab39c4222e3", + "name": "axiomAudit", + "manifestFile": "lake-manifest.json", + "inputRev": "46024e005996495c65ef609368e11ab39c4222e3", + "inherited": false, + "configFile": "lakefile.toml" + }, { "url": "https://github.com/leanprover-community/mathlib4.git", "type": "git", diff --git a/lean/disaster-recovery/lakefile.toml b/lean/disaster-recovery/lakefile.toml index ac7b91709c4..b983e17c6dc 100644 --- a/lean/disaster-recovery/lakefile.toml +++ b/lean/disaster-recovery/lakefile.toml @@ -1,6 +1,9 @@ name = "disaster_recovery" version = "0.1.0" moreLeanArgs = ["-DwarningAsError=true"] +# Quote the hyphenated executable name for Lean's name parser. +lintDriver = "axiomAudit/\u00abaxiom-audit\u00bb" +lintDriverArgs = ["--root", "DisasterRecovery"] defaultTargets = [ "DisasterRecovery", "canonical-checks", @@ -11,6 +14,11 @@ name = "mathlib" git = "https://github.com/leanprover-community/mathlib4.git" rev = "v4.28.0" +[[require]] +name = "axiomAudit" +git = "https://github.com/leanprover-community/axiom-audit.git" +rev = "46024e005996495c65ef609368e11ab39c4222e3" # v0.1.2 + [[lean_lib]] name = "DisasterRecovery" From f6bc9a89350e1c8b60de64f895f2ff5e4155899d Mon Sep 17 00:00:00 2001 From: achamayou Date: Mon, 7 Sep 2026 19:43:15 +0100 Subject: [PATCH 10/12] Consolidate Lean verification workflow Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> Copilot-Session: ed9f1e31-297c-4592-a089-2d37c49c2434 --- .github/workflows/README.md | 9 ++++++--- .../workflows/{lean-disaster-recovery.yml => lean.yml} | 10 +++++----- 2 files changed, 11 insertions(+), 8 deletions(-) rename .github/workflows/{lean-disaster-recovery.yml => lean.yml} (85%) diff --git a/.github/workflows/README.md b/.github/workflows/README.md index fa2bf87b867..bf65dc78162 100644 --- a/.github/workflows/README.md +++ b/.github/workflows/README.md @@ -101,9 +101,12 @@ Runs on pull requests that change `tla/` or `src/consensus/aft/raft.h`. File: `tla-shallow.yml` 3rd party dependencies: None -# Lean Disaster Recovery +# Lean -Builds the canonical Lean disaster recovery model with `lake build --wfail`, +Runs all Lean verification for the repository. Future Lean checks should be +added as jobs to this workflow. + +The disaster recovery job builds the canonical model with `lake build --wfail`, audits its transitive axiom dependencies with `lake lint`, and runs its executable canonical behavior checks on relevant pull requests. The build and audit include both the human-reviewed model and system properties @@ -111,7 +114,7 @@ and the proof implementation files marked as generated for review purposes. The standard `mk_all --check` command ensures that the audit root imports every library module, so newly added proofs cannot silently escape the checks. -File: `lean-disaster-recovery.yml` +File: `lean.yml` 3rd party dependencies: None # Vendored Dependency Verification diff --git a/.github/workflows/lean-disaster-recovery.yml b/.github/workflows/lean.yml similarity index 85% rename from .github/workflows/lean-disaster-recovery.yml rename to .github/workflows/lean.yml index 31085ba5efa..081a8fc0604 100644 --- a/.github/workflows/lean-disaster-recovery.yml +++ b/.github/workflows/lean.yml @@ -1,10 +1,10 @@ -name: "Lean Disaster Recovery" +name: "Lean" on: pull_request: paths: - - "lean/disaster-recovery/**" - - ".github/workflows/lean-disaster-recovery.yml" + - "lean/**" + - ".github/workflows/lean.yml" concurrency: group: ${{ github.workflow }}-${{ github.ref }} @@ -13,8 +13,8 @@ concurrency: permissions: read-all jobs: - canonical-model: - name: Canonical model and proofs + disaster-recovery: + name: Disaster recovery model and proofs runs-on: ubuntu-latest timeout-minutes: 30 From 7d32f3e4bbef4283f0251190e53a9a4ecb9ff6d9 Mon Sep 17 00:00:00 2001 From: achamayou Date: Mon, 7 Sep 2026 19:51:53 +0100 Subject: [PATCH 11/12] Share Lean build ignore rule Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> Copilot-Session: ed9f1e31-297c-4592-a089-2d37c49c2434 --- lean/.gitignore | 1 + lean/disaster-recovery/.gitignore | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) create mode 100644 lean/.gitignore delete mode 100644 lean/disaster-recovery/.gitignore diff --git a/lean/.gitignore b/lean/.gitignore new file mode 100644 index 00000000000..01f8cdb637d --- /dev/null +++ b/lean/.gitignore @@ -0,0 +1 @@ +.lake/ diff --git a/lean/disaster-recovery/.gitignore b/lean/disaster-recovery/.gitignore deleted file mode 100644 index 4080d07dfc3..00000000000 --- a/lean/disaster-recovery/.gitignore +++ /dev/null @@ -1 +0,0 @@ -/.lake/ From fa9f0e811fce5a6540a356005f82c1ff3a18d992 Mon Sep 17 00:00:00 2001 From: achamayou Date: Mon, 7 Sep 2026 20:18:11 +0100 Subject: [PATCH 12/12] Upgrade Lean disaster recovery to 4.33.1 Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> Copilot-Session: ed9f1e31-297c-4592-a089-2d37c49c2434 --- .../Proofs/GlobalTemporal.lean | 10 +++---- .../DisasterRecovery/Proofs/Quorum.lean | 2 +- lean/disaster-recovery/README.md | 2 +- lean/disaster-recovery/lake-manifest.json | 29 ++++++++++--------- lean/disaster-recovery/lakefile.toml | 2 +- lean/disaster-recovery/lean-toolchain | 2 +- 6 files changed, 24 insertions(+), 23 deletions(-) diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean index 79c9db807a0..1d48f8e043a 100644 --- a/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/GlobalTemporal.lean @@ -1856,7 +1856,7 @@ lemma next_preserves_announcements_live rw [identity.2] at opening exact Or.inl ⟨sourceState, - by simpa [identity.1] using found, + by simpa [identity.1, Global.nodeState] using found, opening⟩ | deliver delivered => intro envelope membership payload @@ -2873,9 +2873,9 @@ lemma fair_target_terminal_after_completion rcases fair_opening_completes execution initial fair openingActive targetOpening with ⟨completedAt, deliveryCompleted, targetCompleted⟩ + rw [targetEq] at targetCompleted exact - ⟨completedAt, by omega, - by simpa [targetEq] using (Or.inr targetCompleted)⟩ + ⟨completedAt, by omega, Or.inr targetCompleted⟩ · exact ⟨start, Nat.le_refl start, by simpa [targetEq] using terminal⟩ · have openingActive := @@ -2885,9 +2885,9 @@ lemma fair_target_terminal_after_completion rcases fair_opening_completes execution initial fair openingActive opening with ⟨completedAt, startCompleted, targetCompleted⟩ + rw [targetEq] at targetCompleted exact - ⟨completedAt, startCompleted, - by simpa [targetEq] using (Or.inr targetCompleted)⟩ + ⟨completedAt, startCompleted, Or.inr targetCompleted⟩ lemma fair_all_terminal_after_completion {config : Config} diff --git a/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean b/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean index 48bde6e6e2a..ad568a25707 100644 --- a/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean +++ b/lean/disaster-recovery/DisasterRecovery/Proofs/Quorum.lean @@ -1307,7 +1307,7 @@ lemma quorum_lists_intersect expected.length / 2 + 1 <= second.length) : exists value, value ∈ first /\ value ∈ second := by by_contra noShared - push_neg at noShared + push Not at noShared have disjoint : Disjoint first.toFinset second.toFinset := Finset.disjoint_left.mpr (by intro value firstMember secondMember diff --git a/lean/disaster-recovery/README.md b/lean/disaster-recovery/README.md index d64dac46ca3..c7808aa8dab 100644 --- a/lean/disaster-recovery/README.md +++ b/lean/disaster-recovery/README.md @@ -2,7 +2,7 @@ This package contains the canonical Lean model of CCF's C++ recovery decision protocol and its permanent safety and liveness proofs. It is pinned to Lean -4.28.0 and Mathlib `v4.28.0`. +4.33.1 and Mathlib `v4.33.1`. ## Model diff --git a/lean/disaster-recovery/lake-manifest.json b/lean/disaster-recovery/lake-manifest.json index 7eefb7f0600..6c10c12ab94 100644 --- a/lean/disaster-recovery/lake-manifest.json +++ b/lean/disaster-recovery/lake-manifest.json @@ -1,5 +1,5 @@ { - "version": "1.1.0", + "version": "1.2.0", "packagesDir": ".lake/packages", "packages": [ { @@ -19,10 +19,10 @@ "type": "git", "subDir": null, "scope": "", - "rev": "8f9d9cff6bd728b17a24e163c9402775d9e6a365", + "rev": "0df444a360eaa60ab8c11dca51a86af692955474", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "v4.28.0", + "inputRev": "v4.33.1", "inherited": false, "configFile": "lakefile.lean" }, @@ -31,7 +31,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "55c8532eb21ec9f6d565d51d96b8ca50bd1fbef3", + "rev": "b7eb3304aeae834b12dda98993a37f6a41f6f0bb", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -43,7 +43,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "c5d5b8fe6e5158def25cd28eb94e4141ad97c843", + "rev": "5f4d51b81cbd3f6b32b156bfad9056621a040404", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "85b59af46828c029a9168f2f9c35119bd0721e6e", + "rev": "16f02aa7642864af59f1ff0e384a015994db9118", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -67,10 +67,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "be3b2e63b1bbf496c478cef98b86972a37c1417d", + "rev": "4be2e3d5087eeb272cf5a8853b8f9dd025ef5957", "name": "proofwidgets", "manifestFile": "lake-manifest.json", - "inputRev": "v0.0.87", + "inputRev": "main", "inherited": true, "configFile": "lakefile.lean" }, @@ -79,7 +79,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "f642a64c76df8ba9cb53dba3b919425a0c2aeaf1", + "rev": "3448c0bcc5ce01b2d1546e483ec3620e32df3d0e", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -91,7 +91,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "b8f98e9087e02c8553945a2c5abf07cec8e798c3", + "rev": "92c15be17b7caf78c2ad767ec40f89052d908d81", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -103,7 +103,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "495c008c3e3f4fb4256ff5582ddb3abf3198026f", + "rev": "4488d40d070b9700d4d5a6aa342f0d40c31b2a2d", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -115,14 +115,15 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "4f10f47646cb7d5748d6f423f4a07f98f7bbcc9e", + "rev": "6130a47896ce867c6a4a55373441e59e565bad0f", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.28.0", + "inputRev": "v4.33.0", "inherited": true, "configFile": "lakefile.toml" } ], "name": "disaster_recovery", - "lakeDir": ".lake" + "lakeDir": ".lake", + "fixedToolchain": false } diff --git a/lean/disaster-recovery/lakefile.toml b/lean/disaster-recovery/lakefile.toml index b983e17c6dc..83c7c7e1382 100644 --- a/lean/disaster-recovery/lakefile.toml +++ b/lean/disaster-recovery/lakefile.toml @@ -12,7 +12,7 @@ defaultTargets = [ [[require]] name = "mathlib" git = "https://github.com/leanprover-community/mathlib4.git" -rev = "v4.28.0" +rev = "v4.33.1" [[require]] name = "axiomAudit" diff --git a/lean/disaster-recovery/lean-toolchain b/lean/disaster-recovery/lean-toolchain index 4c685fa085f..a8afa7d1b02 100644 --- a/lean/disaster-recovery/lean-toolchain +++ b/lean/disaster-recovery/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.28.0 +leanprover/lean4:v4.33.1