Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
Fix fuzz lint issues: rename fuzz_github_oauth, add cose fuzz.ml runner
- Rename fuzz_github_oauth.ml to fuzz_oauth.ml to match library (E710)
- Convert ocaml-cose fuzz from raw Crowbar to Alcobar with fuzz.ml
runner (E718)
- Fix odoc warnings in sgp4, tomlt, blob_ref
+141
-40
+76
bench/bench_vds.ml
+76
bench/bench_vds.ml
···
1
+
(* Benchmarks for VDS append throughput.
2
+
3
+
Measures single-append and batch-append at various tree sizes to
4
+
characterize O(log n) behavior and find the throughput ceiling. *)
5
+
6
+
let time f =
7
+
let t0 = Unix.gettimeofday () in
8
+
let r = f () in
9
+
let t1 = Unix.gettimeofday () in
10
+
(r, t1 -. t0)
11
+
12
+
let bench_single_append ~label ~n ~create_vds =
13
+
let vds = create_vds () in
14
+
(* Pre-fill to target size *)
15
+
for i = 0 to n - 2 do
16
+
let key = Fmt.str "k%d" i in
17
+
ignore (Scitt.vds_append vds ~key ~value:key)
18
+
done;
19
+
(* Benchmark the nth append *)
20
+
let key = Fmt.str "k%d" (n - 1) in
21
+
let _proof, elapsed = time (fun () -> Scitt.vds_append vds ~key ~value:key) in
22
+
Printf.printf "%s: single append at n=%d: %.3f ms (%.0f ops/s)\n%!" label n
23
+
(elapsed *. 1000.0) (1.0 /. elapsed)
24
+
25
+
let bench_construction ~label ~n ~create_vds =
26
+
let _vds, elapsed =
27
+
time (fun () ->
28
+
let vds = create_vds () in
29
+
for i = 0 to n - 1 do
30
+
let key = Fmt.str "k%d" i in
31
+
ignore (Scitt.vds_append vds ~key ~value:key)
32
+
done;
33
+
vds)
34
+
in
35
+
let avg_ms = elapsed /. Float.of_int n *. 1000.0 in
36
+
Printf.printf "%s: %d appends in %.3f s (avg %.3f ms/append, %.0f ops/s)\n%!"
37
+
label n elapsed avg_ms
38
+
(Float.of_int n /. elapsed)
39
+
40
+
let bench_batch ~label ~n ~batch_size ~create_vds =
41
+
let vds = create_vds () in
42
+
let batches = n / batch_size in
43
+
let _proofs, elapsed =
44
+
time (fun () ->
45
+
for b = 0 to batches - 1 do
46
+
let entries =
47
+
List.init batch_size (fun i ->
48
+
let idx = (b * batch_size) + i in
49
+
let key = Fmt.str "k%d" idx in
50
+
(key, key))
51
+
in
52
+
ignore (Scitt.vds_batch_append vds entries)
53
+
done)
54
+
in
55
+
let total = batches * batch_size in
56
+
Printf.printf "%s: %d entries in batches of %d: %.3f s (%.0f ops/s)\n%!" label
57
+
total batch_size elapsed
58
+
(Float.of_int total /. elapsed)
59
+
60
+
let () =
61
+
let create_mem () = Scitt.Vds_rfc9162.in_memory () in
62
+
Printf.printf "=== VDS Benchmark ===\n\n";
63
+
Printf.printf "--- Single append at various tree sizes ---\n";
64
+
List.iter
65
+
(fun n -> bench_single_append ~label:"in_memory" ~n ~create_vds:create_mem)
66
+
[ 100; 1_000; 10_000; 50_000; 100_000 ];
67
+
Printf.printf "\n--- Full construction ---\n";
68
+
List.iter
69
+
(fun n -> bench_construction ~label:"in_memory" ~n ~create_vds:create_mem)
70
+
[ 1_000; 10_000; 50_000; 100_000 ];
71
+
Printf.printf "\n--- Batch append (10k entries) ---\n";
72
+
List.iter
73
+
(fun batch_size ->
74
+
bench_batch ~label:"in_memory" ~n:10_000 ~batch_size
75
+
~create_vds:create_mem)
76
+
[ 1; 10; 100; 1000 ]
+5
-11
lib/scitt.ml
+5
-11
lib/scitt.ml
···
104
104
List.find_opt (fun (label, _) -> Cbort.Cbor.to_text label = Some key) pairs
105
105
|> Option.map snd
106
106
107
-
108
107
let algorithm_of_key ~algorithm key =
109
108
match (X509.Private_key.key_type key, algorithm) with
110
109
| `P256, None -> Cose.Algorithm.ES256
···
482
481
(Invalid_receipt
483
482
(Fmt.str "unknown hash algorithm_id %d" algorithm_id))
484
483
| Some hash -> (
485
-
let expected_leaf =
486
-
Hash.leaf_hash_with hash encoded_signed
487
-
in
488
-
let sid =
489
-
match service_id with Some s -> s | None -> ""
490
-
in
484
+
let expected_leaf = Hash.leaf_hash_with hash encoded_signed in
485
+
let sid = match service_id with Some s -> s | None -> "" in
491
486
match ts_keys ~service_id:sid with
492
487
| None ->
493
488
(* Untrusted TS — skip this receipt *)
···
503
498
Ok level
504
499
| Ok payload -> (
505
500
match
506
-
Receipt.decode_proof
507
-
(algorithm_id, service_id, cose)
501
+
Receipt.decode_proof (algorithm_id, service_id, cose)
508
502
with
509
503
| Error _ ->
510
504
Log.warn (fun m ->
···
513
507
| Ok r -> (
514
508
match
515
509
check_receipt_leaf ~expected_leaf
516
-
~expected_subject ~expected_issuer_fp
517
-
payload r
510
+
~expected_subject ~expected_issuer_fp payload
511
+
r
518
512
with
519
513
| Error _ ->
520
514
Log.warn (fun m ->
+50
-27
lib/vds.ml
+50
-27
lib/vds.ml
···
33
33
val export : t -> string
34
34
end
35
35
36
-
type t = T : { impl : (module S with type t = 'a); state : 'a } -> t
36
+
type t =
37
+
| T : { impl : (module S with type t = 'a); state : 'a; mu : Mutex.t } -> t
37
38
38
39
let v (type a) (impl : (module S with type t = a)) (state : a) =
39
-
T { impl; state }
40
+
T { impl; state; mu = Mutex.create () }
40
41
41
-
let algorithm_id (T { impl = (module I); state }) = I.algorithm_id state
42
-
let proof_format (T { impl = (module I); state }) = I.proof_format state
42
+
let with_lock mu f =
43
+
Mutex.lock mu;
44
+
Fun.protect ~finally:(fun () -> Mutex.unlock mu) f
45
+
46
+
let algorithm_id (T { impl = (module I); state; _ }) = I.algorithm_id state
47
+
let proof_format (T { impl = (module I); state; _ }) = I.proof_format state
48
+
49
+
let append (T { impl = (module I); state; mu }) ~key ~value =
50
+
with_lock mu (fun () -> I.append state ~key ~value)
51
+
52
+
let lookup (T { impl = (module I); state; mu }) ~key =
53
+
with_lock mu (fun () -> I.lookup state ~key)
43
54
44
-
let append (T { impl = (module I); state }) ~key ~value =
45
-
I.append state ~key ~value
55
+
let root (T { impl = (module I); state; mu }) =
56
+
with_lock mu (fun () -> I.root state)
46
57
47
-
let lookup (T { impl = (module I); state }) ~key = I.lookup state ~key
48
-
let root (T { impl = (module I); state }) = I.root state
49
-
let size (T { impl = (module I); state }) = I.size state
50
-
let export (T { impl = (module I); state }) = I.export state
58
+
let size (T { impl = (module I); state; mu }) =
59
+
with_lock mu (fun () -> I.size state)
60
+
61
+
let export (T { impl = (module I); state; mu }) =
62
+
with_lock mu (fun () -> I.export state)
63
+
64
+
let batch_append (T { impl = (module I); state; mu }) entries =
65
+
with_lock mu (fun () ->
66
+
let rec go acc = function
67
+
| [] -> Ok (List.rev acc)
68
+
| (key, value) :: rest -> (
69
+
match I.append state ~key ~value with
70
+
| Ok proof -> go (proof :: acc) rest
71
+
| Error e -> Error e)
72
+
in
73
+
go [] entries)
51
74
52
75
(* -- Shared RFC 9162 algorithms -- *)
53
76
···
75
98
t.len <- t.len + 1
76
99
end
77
100
78
-
(** Internal node cache. In an append-only tree, compute_root(offset, len)
79
-
is immutable once all [len] leaves at [offset] exist. Cache hits make
101
+
(** Internal node cache. In an append-only tree, compute_root(offset, len) is
102
+
immutable once all [len] leaves at [offset] exist. Cache hits make
80
103
inclusion_path O(log n) instead of O(n). *)
81
104
module Node_cache = struct
82
105
type t = {
···
103
126
in
104
127
let node_hash = Hash.node_hash_with t.hash in
105
128
let h =
106
-
node_hash
107
-
(compute_root t off split)
129
+
node_hash (compute_root t off split)
108
130
(compute_root t (off + split) (len - split))
109
131
in
110
132
Hashtbl.replace t.tbl key h;
111
133
h
112
134
113
-
(** RFC 9162 §2.1.3.1: PATH(m, D_n). Returns path in leaf-to-root order.
114
-
O(log n) per call — sibling subtree hashes are cache hits from prior
115
-
appends. *)
135
+
(** RFC 9162 §2.1.3.1: PATH(m, D_n). Returns path in leaf-to-root order. O(log
136
+
n) per call — sibling subtree hashes are cache hits from prior appends. *)
116
137
let inclusion_path t off len idx =
117
138
let rec go off len idx acc =
118
139
if len <= 1 then acc
119
140
else
120
141
let split =
121
-
let rec p2 k =
122
-
if k >= len || k * 2 < 0 then k / 2 else p2 (k * 2)
123
-
in
142
+
let rec p2 k = if k >= len || k * 2 < 0 then k / 2 else p2 (k * 2) in
124
143
p2 1
125
144
in
126
145
if idx < split then
127
-
go off split idx
128
-
(compute_root t (off + split) (len - split) :: acc)
146
+
go off split idx (compute_root t (off + split) (len - split) :: acc)
129
147
else
130
148
go (off + split) (len - split) (idx - split)
131
149
(compute_root t off split :: acc)
···
331
349
v
332
350
(module Impl)
333
351
Impl.
334
-
{ db; hash; entries; empty_hash = hash.Hash.digest ""; hashes; compact;
335
-
ncache = Node_cache.create hash (Growable.get hashes) }
352
+
{
353
+
db;
354
+
hash;
355
+
entries;
356
+
empty_hash = hash.Hash.digest "";
357
+
hashes;
358
+
compact;
359
+
ncache = Node_cache.create hash (Growable.get hashes);
360
+
}
336
361
end
337
362
338
363
(* -- Import -- *)
···
400
425
| Some h -> Ok h
401
426
| None -> err_unknown_algorithm algorithm_id
402
427
in
403
-
let expected_root =
404
-
Option.bind (find_text "root") Cbort.Cbor.to_bytes
405
-
in
428
+
let expected_root = Option.bind (find_text "root") Cbort.Cbor.to_bytes in
406
429
let* entries =
407
430
match Option.bind (find_text "entries") Cbort.Cbor.to_array with
408
431
| None -> Error "import: missing entries field"
+8
-1
lib/vds.mli
+8
-1
lib/vds.mli
···
55
55
(** [proof_format t] is the proof format. *)
56
56
57
57
val append : t -> key:string -> value:string -> (inclusion_proof, string) result
58
-
(** [append t ~key ~value] adds an entry and returns an inclusion proof. *)
58
+
(** [append t ~key ~value] adds an entry and returns an inclusion proof.
59
+
Thread-safe: all VDS operations are serialized with a mutex. *)
60
+
61
+
val batch_append :
62
+
t -> (string * string) list -> (inclusion_proof list, string) result
63
+
(** [batch_append t entries] appends all [(key, value)] pairs in a single locked
64
+
operation. Returns an inclusion proof for each entry. More efficient than
65
+
individual appends for bulk loading. *)
59
66
60
67
val lookup : t -> key:string -> string option
61
68
(** [lookup t ~key] retrieves the value stored under [key]. *)
+2
-1
test/test_scitt.ml
+2
-1
test/test_scitt.ml
···
614
614
~issuer_key:issuer_pub decoded
615
615
with
616
616
| Ok _ -> Alcotest.fail "should reject receipt signed by wrong TS key"
617
-
| Error _ -> () (* rejected — correct (signature fail or no trusted receipts) *))
617
+
| Error _ ->
618
+
() (* rejected — correct (signature fail or no trusted receipts) *))
618
619
619
620
let test_wrong_service_id_rejected () =
620
621
(* A receipt from TS "test-ts" should be rejected if ts_keys only trusts "other-ts" *)