Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
irmin: full SCITT proof verification — 20/20 + 6/6 tests pass
+142
-8
+24
-3
lib/atp/scitt_atp.ml
+24
-3
lib/atp/scitt_atp.ml
···
30
30
31
31
let hash_equal = Atp.Cid.equal
32
32
let hash_block data = Atp.Cid.v `Dag_cbor data
33
+
let hash_to_bytes = Atp.Cid.to_raw_bytes
34
+
let hash_of_bytes = Atp.Cid.of_raw_bytes
35
+
let block_to_bytes s = s
36
+
let block_of_bytes s = s
33
37
end)
34
38
35
39
(* MST parse: decode DAG-CBOR MST node, extract entries *)
···
177
181
| Some (S.Any leaf) -> (S.Any leaf, S.get leaf)
178
182
| None -> (S.Any c, None))
179
183
in
180
-
ignore proof;
181
-
(* For now, encode proof as empty — proper CBOR encoding TODO *)
184
+
(* Encode proof as CBOR: [repo_key, [before, after, [[cid, block], ...]]] *)
185
+
let proof_cbor =
186
+
Cbort.Cbor.array
187
+
[
188
+
Cbort.Cbor.bytes (Atp.Cid.to_raw_bytes proof.before);
189
+
Cbort.Cbor.bytes (Atp.Cid.to_raw_bytes proof.after);
190
+
Cbort.Cbor.array
191
+
(List.map
192
+
(fun (cid, data) ->
193
+
Cbort.Cbor.array
194
+
[
195
+
Cbort.Cbor.bytes (Atp.Cid.to_raw_bytes cid);
196
+
Cbort.Cbor.bytes data;
197
+
])
198
+
proof.blocks);
199
+
]
200
+
in
201
+
let encoded_proof = Cbort.encode_string Cbort.any proof_cbor in
182
202
let vdp_cbor =
183
-
Cbort.Cbor.array [ Cbort.Cbor.string rk; Cbort.Cbor.bytes "" ]
203
+
Cbort.Cbor.array
204
+
[ Cbort.Cbor.string rk; Cbort.Cbor.bytes encoded_proof ]
184
205
in
185
206
let vdp_bytes = Cbort.encode_string Cbort.any vdp_cbor in
186
207
let root_raw = Atp.Cid.to_raw_bytes tree_root in
+118
-5
lib/proof.ml
+118
-5
lib/proof.ml
···
68
68
| _ -> None)
69
69
| _ -> None
70
70
71
-
(** Verify an MST inclusion proof.
71
+
(* ATProto MST schema — same as in scitt_atp.ml *)
72
+
module S = Irmin.Schema.Make (struct
73
+
type hash = Atp.Cid.t
74
+
type block = string
75
+
76
+
let hash_equal = Atp.Cid.equal
77
+
let hash_block data = Atp.Cid.v `Dag_cbor data
78
+
let hash_to_bytes = Atp.Cid.to_raw_bytes
79
+
let hash_of_bytes = Atp.Cid.of_raw_bytes
80
+
let block_to_bytes s = s
81
+
let block_of_bytes s = s
82
+
end)
83
+
84
+
let mst_parse : S.parse =
85
+
fun data ->
86
+
try
87
+
let node = Atp.Mst.Raw.decode_bytes data in
88
+
let rec decompress prev = function
89
+
| [] -> []
90
+
| (e : Atp.Mst.Raw.entry) :: rest ->
91
+
let key = String.sub prev 0 e.p ^ e.k in
92
+
(key, (`Link e.v : S.child)) :: decompress key rest
93
+
in
94
+
S.Named (decompress "" node.e)
95
+
with _ -> S.Named []
96
+
97
+
let mst_serialize : S.serialize = fun _children -> ""
98
+
let ( => ) = S.( => )
72
99
73
-
TODO: adapt to new Irmin Schema proof model. The proof is a heap;
74
-
verification replays the cursor navigation. *)
75
-
let verify_mst ~hash:_ ~expected_leaf:_ ~expected_repo_key:_ ~root:_ _path =
76
-
Error "MST proof verification: being migrated to new Irmin Schema API"
100
+
let repo_schema =
101
+
S.fix (fun _self ->
102
+
S.node ~parse:mst_parse ~serialize:mst_serialize [ "*" => S.opaque ])
103
+
104
+
(** Decode a CBOR-encoded proof and verify via Schema.verify. *)
105
+
let verify_mst ~hash ~expected_leaf ~expected_repo_key ~root path =
106
+
match path with
107
+
| [ vdp_data ] -> (
108
+
match Cbort.decode_string Cbort.any vdp_data with
109
+
| Error _ -> Error "MST vdp: invalid CBOR"
110
+
| Ok vdp_cbor -> (
111
+
match Cbort.Cbor.to_array vdp_cbor with
112
+
| Some [ key_cbor; proof_cbor ] -> (
113
+
let repo_key =
114
+
Option.value ~default:"" (Cbort.Cbor.to_text key_cbor)
115
+
in
116
+
if not (Eqaf.equal repo_key expected_repo_key) then
117
+
Error "MST proof repo_key mismatch"
118
+
else
119
+
let proof_bytes =
120
+
Option.value ~default:"" (Cbort.Cbor.to_bytes proof_cbor)
121
+
in
122
+
(* Decode the proof CBOR: [before, after, [[cid, block], ...]] *)
123
+
match Cbort.decode_string Cbort.any proof_bytes with
124
+
| Error _ -> Error "MST proof: invalid CBOR"
125
+
| Ok proof_arr -> (
126
+
match Cbort.Cbor.to_array proof_arr with
127
+
| Some [ before_cbor; after_cbor; blocks_cbor ] -> (
128
+
let before_bytes =
129
+
Option.value ~default:""
130
+
(Cbort.Cbor.to_bytes before_cbor)
131
+
in
132
+
let after_bytes =
133
+
Option.value ~default:""
134
+
(Cbort.Cbor.to_bytes after_cbor)
135
+
in
136
+
let before = Atp.Cid.of_raw_bytes before_bytes in
137
+
let after = Atp.Cid.of_raw_bytes after_bytes in
138
+
(* Check root matches *)
139
+
let expected_root = Atp.Cid.of_raw_bytes root in
140
+
if not (Atp.Cid.equal before expected_root) then
141
+
Error "MST proof: root mismatch"
142
+
else
143
+
let blocks =
144
+
match Cbort.Cbor.to_array blocks_cbor with
145
+
| Some items ->
146
+
List.filter_map
147
+
(fun item ->
148
+
match Cbort.Cbor.to_array item with
149
+
| Some [ cid_cbor; data_cbor ] ->
150
+
let cid_bytes =
151
+
Option.value ~default:""
152
+
(Cbort.Cbor.to_bytes cid_cbor)
153
+
in
154
+
let data =
155
+
Option.value ~default:""
156
+
(Cbort.Cbor.to_bytes data_cbor)
157
+
in
158
+
Some
159
+
(Atp.Cid.of_raw_bytes cid_bytes, data)
160
+
| _ -> None)
161
+
items
162
+
| None -> []
163
+
in
164
+
let proof = S.proof_of_blocks ~before ~after blocks in
165
+
(* Verify by replaying the lookup *)
166
+
match
167
+
S.verify proof repo_schema (fun c ->
168
+
match S.step c repo_key with
169
+
| Some (S.Any leaf) -> (S.Any leaf, S.get leaf)
170
+
| None -> (S.Any c, None))
171
+
with
172
+
| Ok (Some dagcbor) -> (
173
+
match extract_cose dagcbor with
174
+
| Some cose ->
175
+
let leaf = hash.Hash.digest ("\x00" ^ cose) in
176
+
if Eqaf.equal leaf expected_leaf then
177
+
Ok Merkle_proof
178
+
else
179
+
Error "MST proof: cose leaf hash mismatch"
180
+
| None ->
181
+
Error
182
+
"MST proof: cannot extract cose from record"
183
+
)
184
+
| Ok None -> Error "MST proof: key not in tree"
185
+
| Error (`Proof_failure msg) ->
186
+
Error ("MST proof mismatch: " ^ msg))
187
+
| _ -> Error "MST proof: expected [before, after, blocks]"))
188
+
| _ -> Error "MST vdp must be [repo_key, proof_cbor]"))
189
+
| _ -> Error "MST receipt must have exactly one proof entry"