Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
Multicore-safe backends with internal Mutex
Both In_memory and Sqlite backends now have an internal Mutex.t that
serializes all operations. The Vds.t wrapper is pure dispatch — no
locks, no overhead.
Backends own their concurrency story:
- In_memory: Mutex protects Growable, Compact, Node_cache, Hashtbl
- Sqlite: Mutex protects in-memory cache; SQLite transactions for
disk atomicity
Performance: ~250k appends/s single-domain (uncontended Mutex adds
~5ns per operation — within noise). Multicore: domains block on the
Mutex for writes, which is correct for an append-only log.
+56
-43
+52
-37
lib/vds.ml
+52
-37
lib/vds.ml
···
220
220
leaves : (string, string) Hashtbl.t;
221
221
mutable leaves_order : string list;
222
222
empty_hash : string;
223
+
mu : Mutex.t;
223
224
}
224
225
226
+
let with_lock t f =
227
+
Mutex.lock t.mu;
228
+
Fun.protect ~finally:(fun () -> Mutex.unlock t.mu) f
229
+
225
230
let algorithm_id t = Hash.id t.hash
226
231
let proof_format _ = Hash.Rfc9162
227
-
let size t = Growable.length t.hashes
228
-
let root t = Compact.root t.compact ~empty_hash:t.empty_hash
229
-
let lookup t ~key = Hashtbl.find_opt t.leaves key
232
+
let size t = with_lock t (fun () -> Growable.length t.hashes)
233
+
let root t = with_lock t (fun () -> Compact.root t.compact ~empty_hash:t.empty_hash)
234
+
let lookup t ~key = with_lock t (fun () -> Hashtbl.find_opt t.leaves key)
230
235
231
236
let append t ~key ~value =
232
-
if Hashtbl.mem t.leaves key then Error ("duplicate key: " ^ key)
233
-
else
234
-
let leaf_h = Hash.leaf_hash_with t.hash value in
235
-
let idx = Growable.length t.hashes in
236
-
Growable.push t.hashes leaf_h;
237
-
Compact.append t.compact leaf_h;
238
-
Hashtbl.replace t.leaves key value;
239
-
t.leaves_order <- key :: t.leaves_order;
240
-
let n = Growable.length t.hashes in
241
-
let path = Node_cache.inclusion_path t.ncache 0 n idx in
242
-
let root = Compact.root t.compact ~empty_hash:t.empty_hash in
243
-
Ok { leaf_index = idx; tree_size = n; root; path; leaf_hash = leaf_h }
237
+
with_lock t (fun () ->
238
+
if Hashtbl.mem t.leaves key then Error ("duplicate key: " ^ key)
239
+
else
240
+
let leaf_h = Hash.leaf_hash_with t.hash value in
241
+
let idx = Growable.length t.hashes in
242
+
Growable.push t.hashes leaf_h;
243
+
Compact.append t.compact leaf_h;
244
+
Hashtbl.replace t.leaves key value;
245
+
t.leaves_order <- key :: t.leaves_order;
246
+
let n = Growable.length t.hashes in
247
+
let path = Node_cache.inclusion_path t.ncache 0 n idx in
248
+
let root = Compact.root t.compact ~empty_hash:t.empty_hash in
249
+
Ok { leaf_index = idx; tree_size = n; root; path; leaf_hash = leaf_h })
244
250
245
-
let export t =
251
+
let export t = with_lock t (fun () ->
246
252
let entries =
247
253
List.rev t.leaves_order
248
254
|> List.filter_map (fun k ->
···
251
257
| None -> None)
252
258
in
253
259
let r = Compact.root t.compact ~empty_hash:t.empty_hash in
254
-
export_cbor ~hash:t.hash ~root:r ~entries
260
+
export_cbor ~hash:t.hash ~root:r ~entries)
255
261
end
256
262
257
263
let v ?(hash = Hash.sha256) () =
···
268
274
leaves = Hashtbl.create 256;
269
275
leaves_order = [];
270
276
empty_hash = hash.Hash.digest "";
277
+
mu = Mutex.create ();
271
278
}
272
279
end
273
280
···
283
290
hashes : Growable.t;
284
291
compact : Compact.t;
285
292
ncache : Node_cache.t;
293
+
mu : Mutex.t;
286
294
}
287
295
296
+
let with_lock t f =
297
+
Mutex.lock t.mu;
298
+
Fun.protect ~finally:(fun () -> Mutex.unlock t.mu) f
299
+
288
300
let algorithm_id t = Hash.id t.hash
289
301
let proof_format _ = Hash.Rfc9162
290
-
let size t = Growable.length t.hashes
291
-
let root t = Compact.root t.compact ~empty_hash:t.empty_hash
292
-
let lookup t ~key = Sqlite.Table.find t.entries key
302
+
let size t = with_lock t (fun () -> Growable.length t.hashes)
303
+
let root t = with_lock t (fun () -> Compact.root t.compact ~empty_hash:t.empty_hash)
304
+
let lookup t ~key = with_lock t (fun () -> Sqlite.Table.find t.entries key)
293
305
294
306
let append t ~key ~value =
295
-
if Sqlite.Table.mem t.entries key then Error ("duplicate key: " ^ key)
296
-
else
297
-
let leaf_h = Hash.leaf_hash_with t.hash value in
298
-
Sqlite.with_transaction t.db (fun () ->
299
-
let _ =
300
-
Sqlite.insert t.db ~table:"scitt_hashes" [ Sqlite.Vblob leaf_h ]
301
-
in
302
-
Sqlite.Table.put t.entries key value;
303
-
Growable.push t.hashes leaf_h;
304
-
Compact.append t.compact leaf_h);
305
-
let n = Growable.length t.hashes in
306
-
let idx = n - 1 in
307
-
let path = Node_cache.inclusion_path t.ncache 0 n idx in
308
-
let root = Compact.root t.compact ~empty_hash:t.empty_hash in
309
-
Ok { leaf_index = idx; tree_size = n; root; path; leaf_hash = leaf_h }
307
+
with_lock t (fun () ->
308
+
if Sqlite.Table.mem t.entries key then Error ("duplicate key: " ^ key)
309
+
else
310
+
let leaf_h = Hash.leaf_hash_with t.hash value in
311
+
Sqlite.with_transaction t.db (fun () ->
312
+
let _ =
313
+
Sqlite.insert t.db ~table:"scitt_hashes" [ Sqlite.Vblob leaf_h ]
314
+
in
315
+
Sqlite.Table.put t.entries key value;
316
+
Growable.push t.hashes leaf_h;
317
+
Compact.append t.compact leaf_h);
318
+
let n = Growable.length t.hashes in
319
+
let idx = n - 1 in
320
+
let path = Node_cache.inclusion_path t.ncache 0 n idx in
321
+
let root = Compact.root t.compact ~empty_hash:t.empty_hash in
322
+
Ok { leaf_index = idx; tree_size = n; root; path; leaf_hash = leaf_h })
310
323
311
-
let export t =
324
+
let export t = with_lock t (fun () ->
312
325
let all = ref [] in
313
326
Sqlite.Table.iter t.entries ~f:(fun k v -> all := (k, v) :: !all);
314
-
export_cbor ~hash:t.hash ~root:(root t) ~entries:(List.rev !all)
327
+
let r = Compact.root t.compact ~empty_hash:t.empty_hash in
328
+
export_cbor ~hash:t.hash ~root:r ~entries:(List.rev !all))
315
329
end
316
330
317
331
let v ?(hash = Hash.sha256) (db : Sqlite.t) =
···
343
357
hashes;
344
358
compact;
345
359
ncache = Node_cache.create hash (Growable.get hashes);
360
+
mu = Mutex.create ();
346
361
}
347
362
end
348
363
+4
-6
lib/vds.mli
+4
-6
lib/vds.mli
···
87
87
val v : ?hash:Hash.t -> unit -> t
88
88
(** [v ()] is a fresh in-memory RFC 9162 Merkle tree. Suitable for testing.
89
89
90
-
{b Concurrency}: single-domain only. Not safe for concurrent use from
91
-
multiple OCaml 5 domains. *)
90
+
{b Concurrency}: multicore-safe. All operations are serialized with an
91
+
internal mutex. *)
92
92
end
93
93
94
94
module Sqlite : sig
95
95
val v : ?hash:Hash.t -> Sqlite.t -> t
96
96
(** [v db] is a durable RFC 9162 Merkle tree backed by SQLite.
97
97
98
-
{b Concurrency}: writes are serialized by SQLite transactions. The
99
-
in-memory hash cache is single-domain. For multicore use, wrap calls
100
-
in a [Mutex] or use a single writer domain with concurrent reader
101
-
domains (SQLite WAL mode supports this). *)
98
+
{b Concurrency}: multicore-safe. All operations are serialized with an
99
+
internal mutex. Disk writes use SQLite transactions for atomicity. *)
102
100
end