diff --git a/README.md b/README.md index 4ab5605..d49c0f5 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ the same discipline as the four `*-ed25519-verified` subject corpora. | L2 | MTH, Root, ConsRec definitions + termination | **done** (cones: propext, LTLAcc.sha256, Quot.sound) | | L3 | inclusion completeness (Theorem 1) | **done** (incl_complete: propext, Classical.choice, LTLAcc.sha256, Quot.sound) | | L4 | root binding for inclusion (Lemma 2, Path instance) | **done** (root_binding; boundary = single sha256 axiom) | -| L5 | inclusion soundness = collision extractor (Theorem 2) **done**; consistency (Theorem 3) pending | +| L5 | inclusion soundness = EXPLICIT collision extractor extractIncl+correctness (Theorem 2) **done, non-vacuous**; consistency (Theorem 3) pending | | L6 | pin-store state machine safety (Proposition 1) | pending | ## Discipline (identical to the subject corpora) diff --git a/verification/Proofs/AxiomCheck.lean b/verification/Proofs/AxiomCheck.lean index 4480d1c..d918dc2 100644 --- a/verification/Proofs/AxiomCheck.lean +++ b/verification/Proofs/AxiomCheck.lean @@ -1,7 +1,7 @@ /- Axiom-cone observation for the audit (Phase 3 of check.sh). -/ import Proofs.Basic import Proofs.Completeness -import Proofs.Binding +import Proofs.Extract #print axioms LTLAcc.domsep #print axioms LTLAcc.kbelow_pos #print axioms LTLAcc.kbelow_lt @@ -13,7 +13,6 @@ import Proofs.Binding #print axioms LTLAcc.Path #print axioms LTLAcc.incl_complete #print axioms LTLAcc.hnode_preimage_inj -#print axioms LTLAcc.hnode_inj_or_collision -#print axioms LTLAcc.hleaf_inj_or_collision -#print axioms LTLAcc.root_binding -#print axioms LTLAcc.incl_sound +#print axioms LTLAcc.IsCollision +#print axioms LTLAcc.extractIncl +#print axioms LTLAcc.extractIncl_correct diff --git a/verification/Proofs/AxiomCheck.olean b/verification/Proofs/AxiomCheck.olean index cc18f98..beb1113 100644 Binary files a/verification/Proofs/AxiomCheck.olean and b/verification/Proofs/AxiomCheck.olean differ diff --git a/verification/Proofs/Binding.lean b/verification/Proofs/Binding.lean deleted file mode 100644 index 3e0308a..0000000 --- a/verification/Proofs/Binding.lean +++ /dev/null @@ -1,185 +0,0 @@ -/- L4 (first instance) of the accumulator pyramid: **root binding for the - inclusion fold** — the Path instance of the paper's Lemma 2 — and - **Theorem 2 (inclusion soundness)** as a constructive statement: - an accepting receipt for a wrong leaf EXHIBITS a SHA-256 collision. - - No collision-resistance assumption appears anywhere: `HasCollision` - is the conclusion, never a hypothesis. -/ -import Proofs.Completeness - -namespace LTLAcc - -/-- Two distinct preimages with equal hash — the jackpot. Constructively - exhibited by the soundness theorems; believing it cannot be found is - the reader's interpretation of SHA-256, exactly as in the paper. -/ -def HasCollision : Prop := - ∃ x y : List UInt8, x ≠ y ∧ sha256 x = sha256 y - -/-- Either two hash values have equal preimage pairs, or their equality - is itself a collision (the paper's case dichotomy at one node). -/ -theorem hnode_inj_or_collision {x y X Y : Hash} - (h : hnode x y = hnode X Y) : - (x = X ∧ y = Y) ∨ HasCollision := by - by_cases hpre : - (0x01 : UInt8) :: (x.val ++ y.val) = 0x01 :: (X.val ++ Y.val) - · exact Or.inl (hnode_preimage_inj hpre) - · exact Or.inr ⟨_, _, hpre, h⟩ - -/-- Likewise at a leaf: equal leaf hashes with distinct data collide. -/ -theorem hleaf_inj_or_collision {d e : Bytes} - (h : hleaf d = hleaf e) : d = e ∨ HasCollision := by - by_cases hde : d = e - · exact Or.inl hde - · refine Or.inr ⟨0x00 :: d, 0x00 :: e, ?_, h⟩ - intro hc; injection hc with _ ht; exact hde ht - -/-- A non-empty list is its `dropLast` plus its last element - (self-contained; no stdlib-name dependence). -/ -theorem eq_dropLast_append_of_getLast? (l : List Hash) (s : Hash) - (h : l.getLast? = some s) : l = l.dropLast ++ [s] := by - induction l with - | nil => simp at h - | cons a t ih => - cases t with - | nil => - simp at h - subst h - rfl - | cons b u => - have hh : (b :: u).getLast? = some s := by - simpa using h - have := ih hh - calc a :: b :: u = a :: (b :: u) := rfl - _ = a :: ((b :: u).dropLast ++ [s]) := by rw [← this] - _ = (a :: b :: u).dropLast ++ [s] := by simp - -/-- **Root binding** (the Path instance of the paper's Lemma 2): if any - reconstruction from `(v, P)` hits the honest root, then either - `(v, P)` IS the honest receipt — leaf hash and every consumed - sibling — or a collision is exhibited. -/ -theorem root_binding (m : Nat) (D : List Bytes) : - ∀ (v : Hash) (P : List Hash), m < D.length → - Root v m D.length P = some (MTH D) → - (v = hleaf (D.getD m []) ∧ P = Path m D) ∨ HasCollision := by - induction m, D using Path.induct with - | case1 m D hle => - intro v P hm h - have h1 : D.length = 1 := by omega - obtain ⟨d, rfl⟩ := exists_singleton_of_length_one D h1 - have hm0 : m = 0 := by simpa using hm - subst hm0 - have hlen : ([d] : List Bytes).length = 1 := rfl - rw [hlen] at h - cases P with - | nil => - rw [Root_one, MTH_single] at h - simp only [Option.some.injEq] at h - left - refine ⟨?_, by rw [Path]; simp⟩ - have hg : ([d] : List Bytes).getD 0 [] = d := rfl - rw [hg]; exact h - | cons p q => - rw [Root_one_cons] at h - simp at h - | case2 m D hgt k hmk ih => - intro v P hm h - have h2 : 2 ≤ D.length := by omega - have hkeq : k = kbelow D.length := rfl - have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2 - have hmk' : m < kbelow D.length := by rw [← hkeq]; exact hmk - have htklen : (D.take k).length = k := by - simp [List.length_take]; omega - cases hP : P.getLast? with - | none => - have hPnil : P = [] := by - cases P with - | nil => rfl - | cons a t => simp at hP - subst hPnil - rw [Root] at h - have hn1 : ¬ D.length = 1 := by omega - have hn0 : ¬ D.length = 0 := by omega - simp [hn1, hn0] at h - | some s => - obtain hsplit := eq_dropLast_append_of_getLast? P s hP - rw [hsplit] at h - rw [Root_left _ _ _ _ _ h2 hmk', ← hkeq] at h - cases hR : Root v m k P.dropLast with - | none => rw [hR] at h; simp at h - | some x => - rw [hR] at h - simp only [Option.map_some, Option.some.injEq] at h - rw [MTH_split D h2, ← hkeq] at h - rcases hnode_inj_or_collision h with ⟨hx, hs⟩ | hc - · have ihm : m < (D.take k).length := by omega - have hR' : Root v m (D.take k).length P.dropLast - = some (MTH (D.take k)) := by rw [htklen, hR, hx] - rcases ih v P.dropLast ihm hR' with ⟨hv, hPd⟩ | hc - · left - refine ⟨?_, ?_⟩ - · rw [hv]; exact congrArg hleaf (getD_take D k m hmk) - · have hRHS : Path m D = Path m (D.take k) ++ [MTH (D.drop k)] := by - rw [Path]; simp only [if_neg hgt, ← hkeq, if_pos hmk] - rw [hRHS, hsplit, hPd, hs] - · exact Or.inr hc - · exact Or.inr hc - | case3 m D hgt k hmk ih => - intro v P hm h - have h2 : 2 ≤ D.length := by omega - have hkeq : k = kbelow D.length := rfl - have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2 - have hkp : 0 < k := by rw [hkeq]; exact kbelow_pos D.length - have hmk' : ¬ m < kbelow D.length := by rw [← hkeq]; exact hmk - have hdplen : (D.drop k).length = D.length - k := by - simp [List.length_drop] - cases hP : P.getLast? with - | none => - have hPnil : P = [] := by - cases P with - | nil => rfl - | cons a t => simp at hP - subst hPnil - rw [Root] at h - have hn1 : ¬ D.length = 1 := by omega - have hn0 : ¬ D.length = 0 := by omega - simp [hn1, hn0] at h - | some s => - obtain hsplit := eq_dropLast_append_of_getLast? P s hP - rw [hsplit] at h - rw [Root_right _ _ _ _ _ h2 hmk', ← hkeq] at h - cases hR : Root v (m - k) (D.length - k) P.dropLast with - | none => rw [hR] at h; simp at h - | some x => - rw [hR] at h - simp only [Option.map_some, Option.some.injEq] at h - rw [MTH_split D h2, ← hkeq] at h - rcases hnode_inj_or_collision h with ⟨hs, hx⟩ | hc - · have ihm : m - k < (D.drop k).length := by omega - have hR' : Root v (m - k) (D.drop k).length P.dropLast - = some (MTH (D.drop k)) := by rw [hdplen, hR, hx] - rcases ih v P.dropLast ihm hR' with ⟨hv, hPd⟩ | hc - · left - have hidx : k + (m - k) = m := by omega - refine ⟨?_, ?_⟩ - · rw [hv] - have hh : (D.drop k).getD (m - k) [] = D.getD m [] := by - rw [getD_drop, hidx] - exact congrArg hleaf hh - · have hRHS : Path m D = Path (m - k) (D.drop k) ++ [MTH (D.take k)] := by - rw [Path]; simp only [if_neg hgt, ← hkeq, if_neg hmk] - rw [hRHS, hsplit, hPd, hs] - · exact Or.inr hc - · exact Or.inr hc - -/-- **Theorem 2 (Inclusion soundness: position binding)**, paper §6, - constructive form: an accepting receipt whose leaf differs from the - honest leaf at position `m` exhibits a SHA-256 collision. -/ -theorem incl_sound (m : Nat) (D : List Bytes) (hm : m < D.length) - (d : Bytes) (P : List Hash) - (h : Root (hleaf d) m D.length P = some (MTH D)) : - d = D.getD m [] ∨ HasCollision := by - rcases root_binding m D (hleaf d) P hm h with ⟨hv, _⟩ | hc - · exact hleaf_inj_or_collision hv - · exact Or.inr hc - -end LTLAcc diff --git a/verification/Proofs/Completeness.lean b/verification/Proofs/Completeness.lean index 9d8ee43..e310ac0 100644 --- a/verification/Proofs/Completeness.lean +++ b/verification/Proofs/Completeness.lean @@ -161,4 +161,24 @@ theorem incl_complete (m : Nat) (D : List Bytes) (hm : m < D.length) : rw [hrec, MTH_split D h2, ← hkeq] rfl +/-- A non-empty list is its `dropLast` plus its last element + (self-contained; no stdlib-name dependence). -/ +theorem eq_dropLast_append_of_getLast? (l : List Hash) (s : Hash) + (h : l.getLast? = some s) : l = l.dropLast ++ [s] := by + induction l with + | nil => simp at h + | cons a t ih => + cases t with + | nil => + simp at h + subst h + rfl + | cons b u => + have hh : (b :: u).getLast? = some s := by + simpa using h + have := ih hh + calc a :: b :: u = a :: (b :: u) := rfl + _ = a :: ((b :: u).dropLast ++ [s]) := by rw [← this] + _ = (a :: b :: u).dropLast ++ [s] := by simp + end LTLAcc diff --git a/verification/Proofs/Completeness.olean b/verification/Proofs/Completeness.olean index d8d93f5..753fecc 100644 Binary files a/verification/Proofs/Completeness.olean and b/verification/Proofs/Completeness.olean differ diff --git a/verification/Proofs/Extract.lean b/verification/Proofs/Extract.lean new file mode 100644 index 0000000..a9e017d --- /dev/null +++ b/verification/Proofs/Extract.lean @@ -0,0 +1,197 @@ +/- S3.5 — the EXPLICIT collision extractor for inclusion soundness. + + Why a function and not `∃`: `Hash` is a finite type (32-byte lists), + `sha256` has an infinite domain, so `∃ x y, x ≠ y ∧ sha256 x = sha256 y` + is provable by pigeonhole ALONE — a bare-existential soundness theorem + is vacuous, and even a data-carrying `{p // IsCollision p}` disjunct is + inhabited by `Classical.choice`. The paper's Theorem 2 is an *explicit + algorithm* 𝓔; faithfulness demands a named function `extractIncl` and a + correctness statement ABOUT ITS OUTPUT — a claim pigeonhole cannot + discharge, because it pins down *which* pair. -/ +import Proofs.Completeness + +namespace LTLAcc + +/-- A specific colliding pair (predicate on concrete byte strings). -/ +def IsCollision (x y : List UInt8) : Prop := + x ≠ y ∧ sha256 x = sha256 y + +/-- The extractor 𝓔 for inclusion (paper Theorem 2). Given the honest + leaf list `D`, a claimed index `m`, a claimed leaf `d`, and a path + `P`, it walks the honest tree and returns the concrete preimage pair + at the first level where the offered reconstruction diverges from the + honest tree — a node preimage pair high up, or the leaf preimage pair + at the bottom. Total (junk defaults on the branches the soundness + hypothesis excludes). -/ +noncomputable def extractIncl (m : Nat) (D : List Bytes) (d : Bytes) + (P : List Hash) : List UInt8 × List UInt8 := + if D.length ≤ 1 then + -- leaf level: the offered leaf `d` vs the honest leaf `D[m]` + (0x00 :: d, 0x00 :: D.getD m []) + else + let k := kbelow D.length + match P.getLast? with + | none => ([], []) -- excluded: composite size needs a sibling + | some s => + if m < k then + let child := (Root (hleaf d) m k P.dropLast).getD default + if child = MTH (D.take k) ∧ s = MTH (D.drop k) then + extractIncl m (D.take k) d P.dropLast + else + (0x01 :: (child.val ++ s.val), + 0x01 :: ((MTH (D.take k)).val ++ (MTH (D.drop k)).val)) + else + let child := (Root (hleaf d) (m - k) (D.length - k) P.dropLast).getD default + if s = MTH (D.take k) ∧ child = MTH (D.drop k) then + extractIncl (m - k) (D.drop k) d P.dropLast + else + (0x01 :: (s.val ++ child.val), + 0x01 :: ((MTH (D.take k)).val ++ (MTH (D.drop k)).val)) +termination_by D.length +decreasing_by + · simp only [List.length_take] + have h2 : 2 ≤ D.length := by omega + have hk := kbelow_lt D.length h2 + omega + · simp only [List.length_drop] + have hp := kbelow_pos D.length + omega + +/-- **Theorem 2 (Inclusion soundness), explicit form** — the faithful + replacement for the vacuous bare-existential version. If an accepting + receipt opens position `m` to a leaf `d` different from the honest + `D[m]`, then `extractIncl` OUTPUTS a genuine SHA-256 collision. The + statement is about the fixed function's output, so pigeonhole cannot + prove it: it must exhibit that THIS pair collides. -/ +theorem extractIncl_correct (m : Nat) (D : List Bytes) : + ∀ (d : Bytes) (P : List Hash), m < D.length → d ≠ D.getD m [] → + Root (hleaf d) m D.length P = some (MTH D) → + IsCollision (extractIncl m D d P).1 (extractIncl m D d P).2 := by + induction m, D using Path.induct with + | case1 m D hle => + intro d P hm hd h + have h1 : D.length = 1 := by omega + obtain ⟨e, rfl⟩ := exists_singleton_of_length_one D h1 + have hm0 : m = 0 := by simpa using hm + subst hm0 + rw [extractIncl] + simp only [List.length_singleton, if_pos (by omega : (1:Nat) ≤ 1)] + have hlen : ([e] : List Bytes).length = 1 := rfl + rw [hlen] at h + cases P with + | nil => + rw [Root_one, MTH_single] at h + simp only [Option.some.injEq] at h + have hde : d ≠ e := by simpa using hd + refine ⟨?_, ?_⟩ + · intro hc; injection hc with _ ht; exact hde ht + · have hg : ([e] : List Bytes).getD 0 [] = e := rfl + rw [hg]; exact h + | cons p q => + rw [Root_one_cons] at h + exact absurd h (by simp) + | case2 m D hgt k hmk ih => + intro d P hm hd h + have h2 : 2 ≤ D.length := by omega + have hkeq : k = kbelow D.length := rfl + have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2 + have hmk' : m < kbelow D.length := by rw [← hkeq]; exact hmk + have htklen : (D.take k).length = k := by simp [List.length_take]; omega + cases hP : P.getLast? with + | none => + have hPnil : P = [] := by + cases P with + | nil => rfl + | cons a t => simp at hP + subst hPnil + rw [Root] at h + have hn1 : ¬ D.length = 1 := by omega + have hn0 : ¬ D.length = 0 := by omega + simp [hn1, hn0] at h + | some s => + obtain hsplit := eq_dropLast_append_of_getLast? P s hP + have hh := h + rw [hsplit, Root_left _ _ _ _ _ h2 hmk', ← hkeq] at hh + cases hR : Root (hleaf d) m k P.dropLast with + | none => rw [hR] at hh; simp at hh + | some x => + rw [hR] at hh + simp only [Option.map_some, Option.some.injEq] at hh + rw [MTH_split D h2, ← hkeq] at hh + rw [extractIncl] + simp only [if_neg hgt, hP, ← hkeq, if_pos hmk] + have hchild : (Root (hleaf d) m k P.dropLast).getD default = x := by + rw [hR]; rfl + rw [hchild] + by_cases hpair : x = MTH (D.take k) ∧ s = MTH (D.drop k) + · simp only [if_pos hpair] + have ihm : m < (D.take k).length := by omega + have hgetd : (D.take k).getD m [] = D.getD m [] := getD_take D k m hmk + have hd' : d ≠ (D.take k).getD m [] := by rw [hgetd]; exact hd + have hrec : Root (hleaf d) m (D.take k).length P.dropLast + = some (MTH (D.take k)) := by rw [htklen, hR, hpair.1] + exact ih d P.dropLast ihm hd' hrec + · simp only [if_neg hpair] + refine ⟨?_, ?_⟩ + · intro hc + injection hc with _ happ + have hlen : x.val.length = (MTH (D.take k)).val.length := by + rw [x.property, (MTH (D.take k)).property] + obtain ⟨hx, hs⟩ := List.append_inj happ hlen + exact hpair ⟨Subtype.ext hx, Subtype.ext hs⟩ + · exact hh + | case3 m D hgt k hmk ih => + intro d P hm hd h + have h2 : 2 ≤ D.length := by omega + have hkeq : k = kbelow D.length := rfl + have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2 + have hkp : 0 < k := by rw [hkeq]; exact kbelow_pos D.length + have hmk' : ¬ m < kbelow D.length := by rw [← hkeq]; exact hmk + have hdplen : (D.drop k).length = D.length - k := by simp [List.length_drop] + cases hP : P.getLast? with + | none => + have hPnil : P = [] := by + cases P with + | nil => rfl + | cons a t => simp at hP + subst hPnil + rw [Root] at h + have hn1 : ¬ D.length = 1 := by omega + have hn0 : ¬ D.length = 0 := by omega + simp [hn1, hn0] at h + | some s => + obtain hsplit := eq_dropLast_append_of_getLast? P s hP + have hh := h + rw [hsplit, Root_right _ _ _ _ _ h2 hmk', ← hkeq] at hh + cases hR : Root (hleaf d) (m - k) (D.length - k) P.dropLast with + | none => rw [hR] at hh; simp at hh + | some x => + rw [hR] at hh + simp only [Option.map_some, Option.some.injEq] at hh + rw [MTH_split D h2, ← hkeq] at hh + rw [extractIncl] + simp only [if_neg hgt, hP, ← hkeq, if_neg hmk] + have hchild : (Root (hleaf d) (m - k) (D.length - k) P.dropLast).getD default = x := by + rw [hR]; rfl + rw [hchild] + by_cases hpair : s = MTH (D.take k) ∧ x = MTH (D.drop k) + · simp only [if_pos hpair] + have ihm : m - k < (D.drop k).length := by omega + have hidx : k + (m - k) = m := by omega + have hgetd : (D.drop k).getD (m - k) [] = D.getD m [] := by + rw [getD_drop, hidx] + have hd' : d ≠ (D.drop k).getD (m - k) [] := by rw [hgetd]; exact hd + have hrec : Root (hleaf d) (m - k) (D.drop k).length P.dropLast + = some (MTH (D.drop k)) := by rw [hdplen, hR, hpair.2] + exact ih d P.dropLast ihm hd' hrec + · simp only [if_neg hpair] + refine ⟨?_, ?_⟩ + · intro hc + injection hc with _ happ + have hlen : s.val.length = (MTH (D.take k)).val.length := by + rw [s.property, (MTH (D.take k)).property] + obtain ⟨hs, hx⟩ := List.append_inj happ hlen + exact hpair ⟨Subtype.ext hs, Subtype.ext hx⟩ + · exact hh + +end LTLAcc diff --git a/verification/Proofs/Extract.olean b/verification/Proofs/Extract.olean new file mode 100644 index 0000000..92e2711 Binary files /dev/null and b/verification/Proofs/Extract.olean differ diff --git a/verification/Proofs/Probe.olean b/verification/Proofs/Probe.olean new file mode 100644 index 0000000..b3d2e0b Binary files /dev/null and b/verification/Proofs/Probe.olean differ diff --git a/verification/check.sh b/verification/check.sh index 18d627a..f6b8540 100755 --- a/verification/check.sh +++ b/verification/check.sh @@ -17,7 +17,7 @@ export LEAN_MEM_MB="${LEAN_MEM_MB:-4096}" CORES="${LEAN_MAX_CORES:-0-3}" GEN_MODULES=( LTLAcc/HashExternal ) -PROOFS=( Basic Completeness Binding ) +PROOFS=( Basic Completeness Extract ) # Certificates and their exact expected cones (observed at first green # compile, 2026-07-10; any drift in EITHER direction is a failure). @@ -33,10 +33,9 @@ declare -A CONES=( [LTLAcc.Path]="propext, LTLAcc.sha256, Quot.sound" [LTLAcc.incl_complete]="propext, Classical.choice, LTLAcc.sha256, Quot.sound" [LTLAcc.hnode_preimage_inj]="propext" - [LTLAcc.hnode_inj_or_collision]="propext, LTLAcc.sha256" - [LTLAcc.hleaf_inj_or_collision]="LTLAcc.sha256" - [LTLAcc.root_binding]="propext, Classical.choice, LTLAcc.sha256, Quot.sound" - [LTLAcc.incl_sound]="propext, Classical.choice, LTLAcc.sha256, Quot.sound" + [LTLAcc.IsCollision]="LTLAcc.sha256" + [LTLAcc.extractIncl]="propext, LTLAcc.sha256, Quot.sound" + [LTLAcc.extractIncl_correct]="propext, Classical.choice, LTLAcc.sha256, Quot.sound" ) free -m | awk '/Mem:/{if($7<2048){print "FATAL: <2GB RAM available — refusing to compile"; exit 1}}'