Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
scitt: extract proof helpers, narrow exception handlers
- Refactor proof.verify_mst (93 lines) into decode_blocks, run_mst_proof,
check_cose_leaf, verify_mst_inner helpers.
- Replace catch-all 'with _' in mst_parse and copy_block with
Invalid_argument | Failure to avoid hiding unexpected errors.
- Extract err_consistency_first helper for vds.ml E340 patterns.
+79
-82
+2
-2
lib/atp/scitt_atp.ml
+2
-2
lib/atp/scitt_atp.ml
···
44
44
(key, (`Link e.v : S.child)) :: decompress key rest
45
45
in
46
46
S.Named (decompress "" node.e)
47
-
with _ -> S.Named []
47
+
with Invalid_argument _ | Failure _ -> S.Named []
48
48
49
49
let mst_serialize : S.enc =
50
50
fun _children ->
···
150
150
(fun (e : Atp.Mst.Raw.entry) ->
151
151
Option.iter copy_block e.t)
152
152
node.e
153
-
with _ -> ())
153
+
with Invalid_argument _ | Failure _ -> ())
154
154
| None -> ()
155
155
in
156
156
copy_block tree_root;
+72
-76
lib/proof.ml
+72
-76
lib/proof.ml
···
88
88
(key, (`Link e.v : S.child)) :: decompress key rest
89
89
in
90
90
S.Named (decompress "" node.e)
91
-
with _ -> S.Named []
91
+
with Invalid_argument _ | Failure _ -> S.Named []
92
92
93
93
let mst_serialize : S.enc = fun _children -> ""
94
94
let ( => ) = S.( => )
···
99
99
~rules:[ "*" => S.opaque ]
100
100
())
101
101
102
+
(* Decode a [[cid, block]; ...] CBOR list into proof heap entries. *)
103
+
let decode_blocks blocks_cbor =
104
+
match Cbort.Cbor.to_array blocks_cbor with
105
+
| None -> []
106
+
| Some items ->
107
+
List.filter_map
108
+
(fun item ->
109
+
match Cbort.Cbor.to_array item with
110
+
| Some [ cid_cbor; data_cbor ] ->
111
+
let cid_bytes =
112
+
Option.value ~default:"" (Cbort.Cbor.to_bytes cid_cbor)
113
+
in
114
+
let data =
115
+
Option.value ~default:"" (Cbort.Cbor.to_bytes data_cbor)
116
+
in
117
+
Some (Atp.Cid.of_raw_bytes cid_bytes, data)
118
+
| _ -> None)
119
+
items
120
+
121
+
(* Verify the cose leaf hash extracted from the looked-up DAG-CBOR record
122
+
matches [expected_leaf]. *)
123
+
let check_cose_leaf ~hash ~expected_leaf dagcbor =
124
+
match extract_cose dagcbor with
125
+
| None -> Error "MST proof: cannot extract cose from record"
126
+
| Some cose ->
127
+
let leaf = hash.Hash.digest ("\x00" ^ cose) in
128
+
if Eqaf.equal leaf expected_leaf then Ok Merkle_proof
129
+
else Error "MST proof: cose leaf hash mismatch"
130
+
131
+
(* Run the schema-based proof check for [repo_key], producing the looked-up
132
+
record bytes when present. *)
133
+
let run_mst_proof ~before ~after ~blocks ~repo_key =
134
+
let proof : S.proof =
135
+
{ before; after; heap = Irmin.Heap.of_list ~equal:Atp.Cid.equal blocks }
136
+
in
137
+
S.verify proof repo_schema (fun c ->
138
+
match S.step_any c repo_key with
139
+
| Some (S.Step (sc, leaf)) -> (S.Step (sc, leaf), S.get_block leaf)
140
+
| None -> (S.Step (repo_schema, c), None))
141
+
142
+
(* Verify the inner [before, after, blocks] proof structure once we already
143
+
know [repo_key] matches expectations. *)
144
+
let verify_mst_inner ~hash ~expected_leaf ~root ~repo_key proof_bytes =
145
+
match Cbort.decode_string Cbort.any proof_bytes with
146
+
| Error _ -> Error "MST proof: invalid CBOR"
147
+
| Ok proof_arr -> (
148
+
match Cbort.Cbor.to_array proof_arr with
149
+
| Some [ before_cbor; after_cbor; blocks_cbor ] -> (
150
+
let before_bytes =
151
+
Option.value ~default:"" (Cbort.Cbor.to_bytes before_cbor)
152
+
in
153
+
let after_bytes =
154
+
Option.value ~default:"" (Cbort.Cbor.to_bytes after_cbor)
155
+
in
156
+
let before = Atp.Cid.of_raw_bytes before_bytes in
157
+
let after = Atp.Cid.of_raw_bytes after_bytes in
158
+
let expected_root = Atp.Cid.of_raw_bytes root in
159
+
if not (Atp.Cid.equal before expected_root) then
160
+
Error "MST proof: root mismatch"
161
+
else
162
+
let blocks = decode_blocks blocks_cbor in
163
+
match run_mst_proof ~before ~after ~blocks ~repo_key with
164
+
| Ok (Some dagcbor) -> check_cose_leaf ~hash ~expected_leaf dagcbor
165
+
| Ok None -> Error "MST proof: key not in tree"
166
+
| Error (`Proof_failure msg) -> Error ("MST proof mismatch: " ^ msg)
167
+
)
168
+
| _ -> Error "MST proof: expected [before, after, blocks]")
169
+
102
170
(** Decode a CBOR-encoded proof and verify via Schema.verify. *)
103
171
let verify_mst ~hash ~expected_leaf ~expected_repo_key ~root path =
104
172
match path with
···
107
175
| Error _ -> Error "MST vdp: invalid CBOR"
108
176
| Ok vdp_cbor -> (
109
177
match Cbort.Cbor.to_array vdp_cbor with
110
-
| Some [ key_cbor; proof_cbor ] -> (
178
+
| Some [ key_cbor; proof_cbor ] ->
111
179
let repo_key =
112
180
Option.value ~default:"" (Cbort.Cbor.to_text key_cbor)
113
181
in
···
117
185
let proof_bytes =
118
186
Option.value ~default:"" (Cbort.Cbor.to_bytes proof_cbor)
119
187
in
120
-
(* Decode the proof CBOR: [before, after, [[cid, block], ...]] *)
121
-
match Cbort.decode_string Cbort.any proof_bytes with
122
-
| Error _ -> Error "MST proof: invalid CBOR"
123
-
| Ok proof_arr -> (
124
-
match Cbort.Cbor.to_array proof_arr with
125
-
| Some [ before_cbor; after_cbor; blocks_cbor ] -> (
126
-
let before_bytes =
127
-
Option.value ~default:""
128
-
(Cbort.Cbor.to_bytes before_cbor)
129
-
in
130
-
let after_bytes =
131
-
Option.value ~default:""
132
-
(Cbort.Cbor.to_bytes after_cbor)
133
-
in
134
-
let before = Atp.Cid.of_raw_bytes before_bytes in
135
-
let after = Atp.Cid.of_raw_bytes after_bytes in
136
-
(* Check root matches *)
137
-
let expected_root = Atp.Cid.of_raw_bytes root in
138
-
if not (Atp.Cid.equal before expected_root) then
139
-
Error "MST proof: root mismatch"
140
-
else
141
-
let blocks =
142
-
match Cbort.Cbor.to_array blocks_cbor with
143
-
| Some items ->
144
-
List.filter_map
145
-
(fun item ->
146
-
match Cbort.Cbor.to_array item with
147
-
| Some [ cid_cbor; data_cbor ] ->
148
-
let cid_bytes =
149
-
Option.value ~default:""
150
-
(Cbort.Cbor.to_bytes cid_cbor)
151
-
in
152
-
let data =
153
-
Option.value ~default:""
154
-
(Cbort.Cbor.to_bytes data_cbor)
155
-
in
156
-
Some
157
-
(Atp.Cid.of_raw_bytes cid_bytes, data)
158
-
| _ -> None)
159
-
items
160
-
| None -> []
161
-
in
162
-
let proof : S.proof =
163
-
{
164
-
before;
165
-
after;
166
-
heap =
167
-
Irmin.Heap.of_list ~equal:Atp.Cid.equal blocks;
168
-
}
169
-
in
170
-
(* Verify by replaying the lookup *)
171
-
match
172
-
S.verify proof repo_schema (fun c ->
173
-
match S.step_any c repo_key with
174
-
| Some (S.Step (sc, leaf)) ->
175
-
(S.Step (sc, leaf), S.get_block leaf)
176
-
| None -> (S.Step (repo_schema, c), None))
177
-
with
178
-
| Ok (Some dagcbor) -> (
179
-
match extract_cose dagcbor with
180
-
| Some cose ->
181
-
let leaf = hash.Hash.digest ("\x00" ^ cose) in
182
-
if Eqaf.equal leaf expected_leaf then
183
-
Ok Merkle_proof
184
-
else
185
-
Error "MST proof: cose leaf hash mismatch"
186
-
| None ->
187
-
Error
188
-
"MST proof: cannot extract cose from record"
189
-
)
190
-
| Ok None -> Error "MST proof: key not in tree"
191
-
| Error (`Proof_failure msg) ->
192
-
Error ("MST proof mismatch: " ^ msg))
193
-
| _ -> Error "MST proof: expected [before, after, blocks]"))
188
+
verify_mst_inner ~hash ~expected_leaf ~root ~repo_key
189
+
proof_bytes
194
190
| _ -> Error "MST vdp must be [repo_key, proof_cbor]"))
195
191
| _ -> Error "MST receipt must have exactly one proof entry"
+5
-4
lib/vds.ml
+5
-4
lib/vds.ml
···
9
9
let max_statement_size = 16 * 1024 * 1024 (* 16 MiB *)
10
10
let max_proof_path_length = 64
11
11
12
+
let err_consistency_first ~first ~n =
13
+
Error (Fmt.str "consistency: first=%d out of range [1, %d]" first n)
14
+
12
15
type inclusion_proof = {
13
16
leaf_index : int;
14
17
tree_size : int;
···
374
377
let consistency t ~first =
375
378
with_lock t (fun () ->
376
379
let n = Growable.length t.hashes in
377
-
if first <= 0 || first > n then
378
-
Error (Fmt.str "consistency: first=%d out of range [1, %d]" first n)
380
+
if first <= 0 || first > n then err_consistency_first ~first ~n
379
381
else
380
382
let path = Node_cache.consistency_path t.ncache 0 n first in
381
383
let first_root = Node_cache.compute_root t.ncache 0 first in
···
480
482
let consistency t ~first =
481
483
with_lock t (fun () ->
482
484
let n = t.entry_count in
483
-
if first <= 0 || first > n then
484
-
Error (Fmt.str "consistency: first=%d out of range [1, %d]" first n)
485
+
if first <= 0 || first > n then err_consistency_first ~first ~n
485
486
else
486
487
let path = Node_cache.consistency_path t.ncache 0 n first in
487
488
let first_root = Node_cache.compute_root t.ncache 0 first in