mirror of
https://github.com/saymrwulf/ltl-accumulator-verified.git
synced 2026-09-04 20:03:44 +00:00
mrwulf
9972ab4198
Round-2 external reviews (GPT-5.6 + second Claude) converged on the coverage gate being evadable (H1/NEW-1); GPT additionally proved the kit's fidelity target could not run (H2) and the namespace-collision attack that defeats any source-regex fix. This round adopts GPT's required correction in full: - Proofs/Inventory.lean: declaration inventory read from the compiled Lean environment — every constant of every corpus module, fully qualified, unfiltered (compiler auxiliaries and _private mangles pinned too), with kind and axiom cone; own cone walker cross-checked in-process against core collectAxioms (hard error on divergence). - verification/inventory-allowlist.txt: all 218 constants pinned. - inventory_gate.sh: fail-closed diff both directions (UNCLASSIFIED / STALE), INV-COUNT truncation guard, exactly-one-axiom invariant. - check.sh Phase 3b rewritten around the gate + manifest⇔inventory drift checks + CONES⇔inventory cone cross-check (two independent computations must agree). EXCLUDE table gone (sha256/Bytes are ordinary audited entries now). - selftest_audit.sh: 9 adversarial cases against the production gate (attributed/indented/private/instance, namespace collision, smuggled axiom, deleted decl, unmanifested Proofs/ and gen/ modules) + positive control — all defeated (GPT release condition 2). - M1: recursive orphan-olean guard (caught a stray dev artifact on its first run), gen/ dead-file check, corpus-wide single-axiom pin. - L1/NEW-2: acceptIncl_sound drops the redundant hm (derived from hacc.1); cone unchanged. - M2/M3: STATEMENT-MAP counts 230,271/230,016; non-vacuity guard wording narrowed to what the guards actually certify. - README layer table: stale L4/pin-store rows fixed (missed by both round-2 reviewers AND the round-2 revision — found in self-review). - KNOWN-GAPS 12 (audit-gate lineage + residual limits), 13 (round-2 kit target not self-contained); gap 2 count fixed. - RESPONSE-TO-REVIEWERS.md: round-3 disposition of every finding. Kit round 3 additionally ships the complete stdlib-only import closure of pacta.transparency (content-addressed vs pacta 3d81d53), the clean-extraction fidelity transcript (exit 0, 230,271+230,016, zero mismatches), the ATTESTATION GREEN check.sh transcript, and the self-test transcript. The live LTL remains untouched (12 leaves, root bcd15f9d…); attestation stays blocked pending ePrint decision + author review + explicit operator order. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
223 lines
10 KiB
Text
223 lines
10 KiB
Text
/- 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
|
||
|
||
/-- **Permanent non-vacuity witness** (re-audit F1): on a NON-forgery
|
||
input (the offered leaf IS the honest leaf), the extractor's output
|
||
is provably NOT a collision. Hence `extractIncl_correct`'s conclusion
|
||
is false for some inputs — it cannot be discharged by pigeonhole or
|
||
choice, and only the forgery hypotheses make it hold. This theorem
|
||
guards the corpus against any future drift back into vacuity. -/
|
||
theorem extractIncl_nonvacuous :
|
||
¬ IsCollision (extractIncl 0 [([7] : List UInt8)] [7] []).1
|
||
(extractIncl 0 [([7] : List UInt8)] [7] []).2 := by
|
||
rw [extractIncl]
|
||
simp only [List.length_singleton, if_pos (by omega : (1:Nat) ≤ 1)]
|
||
intro hcol
|
||
exact hcol.1 rfl
|
||
|
||
/-- Inclusion soundness through the named acceptance predicate (review F1):
|
||
if `acceptIncl` holds for a wrong leaf, `extractIncl` outputs a
|
||
collision. Ties the object the harness tests to the security theorem.
|
||
The range fact `m < |D|` is `hacc.1` — acceptance carries it, so the
|
||
caller owes nothing beyond acceptance and the wrong-leaf premise
|
||
(review round 2, L1/NEW-2). -/
|
||
theorem acceptIncl_sound (m : Nat) (D : List Bytes)
|
||
(d : Bytes) (P : List Hash) (hd : d ≠ D.getD m [])
|
||
(hacc : acceptIncl d m D.length P (MTH D)) :
|
||
IsCollision (extractIncl m D d P).1 (extractIncl m D d P).2 :=
|
||
extractIncl_correct m D d P hacc.1 hd hacc.2
|
||
|
||
end LTLAcc
|