Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
scitt: make Vds.Make a functor; backends build state via Impl.v
Replace the first-class-module construction path with a functor.
Each backend (In_memory, Sqlite, Scitt_atp) now applies Make(Impl)
at module level and builds its state through an Impl.v with named
parameters, so the public constructor is a one-liner with no inline
record literal.
Promote Scitt_atp's Backend and Impl from nested modules (inside a
function body) to top-level modules, which is what the functor
pattern requires.
The top-level abstract Vds.t is preserved; dispatch goes through an
existential packing the backend module alongside its state.
+246
-236
+183
-181
lib/atp/scitt_atp.ml
+183
-181
lib/atp/scitt_atp.ml
···
58
58
let ( => ) = S.( => )
59
59
let repo_schema = S.fix (fun _self -> mst_node [ "*" => S.opaque ])
60
60
61
-
let v ~heap ~now:clock =
62
-
let module Backend = struct
63
-
type t = {
64
-
mutable head : Atp.Cid.t option;
65
-
values : (string, string) Hashtbl.t;
66
-
}
61
+
module Backend = struct
62
+
type t = {
63
+
heap : (Atp.Cid.t, string) Irmin.Heap.t;
64
+
mutable head : Atp.Cid.t option;
65
+
values : (string, string) Hashtbl.t;
66
+
}
67
67
68
-
let algorithm_id _ = atp_mst_algorithm_id
69
-
let proof_format = Scitt.Prefixed
68
+
let algorithm_id _ = atp_mst_algorithm_id
69
+
let proof_format = Scitt.Prefixed
70
70
71
-
let value_to_dagcbor ~now ~key value =
72
-
let ( let* ) = Result.bind in
73
-
let* now = now () in
74
-
let* issuer, content_type, payload_digest =
75
-
match Scitt.Signed_statement.decode value with
76
-
| Ok signed ->
77
-
let stmt = Scitt.Signed_statement.statement signed in
78
-
Ok
79
-
( Scitt.Statement.issuer stmt,
80
-
Scitt.Statement.content_type stmt,
81
-
Some (Ohex.encode (sha256 (Scitt.Statement.payload stmt))) )
82
-
| Error _ ->
83
-
Error "value is not a valid signed statement (COSE decode failed)"
84
-
in
85
-
let record : Statement_lexicon.main =
86
-
{
87
-
subject = key;
88
-
issuer;
89
-
content_type;
90
-
cose = value;
91
-
payload_digest;
92
-
created_at = now;
93
-
}
94
-
in
95
-
let ( let* ) = Result.bind in
96
-
let* json =
97
-
Json.encode Statement_lexicon.main_json record
98
-
|> Result.map_error Json.Error.to_string
99
-
in
100
-
let* dagcbor_value = Atp.Dagcbor.of_json json in
101
-
Ok (Atp.Dagcbor.encode_string dagcbor_value)
71
+
let value_to_dagcbor ~now ~key value =
72
+
let ( let* ) = Result.bind in
73
+
let* now = now () in
74
+
let* issuer, content_type, payload_digest =
75
+
match Scitt.Signed_statement.decode value with
76
+
| Ok signed ->
77
+
let stmt = Scitt.Signed_statement.statement signed in
78
+
Ok
79
+
( Scitt.Statement.issuer stmt,
80
+
Scitt.Statement.content_type stmt,
81
+
Some (Ohex.encode (sha256 (Scitt.Statement.payload stmt))) )
82
+
| Error _ ->
83
+
Error "value is not a valid signed statement (COSE decode failed)"
84
+
in
85
+
let record : Statement_lexicon.main =
86
+
{
87
+
subject = key;
88
+
issuer;
89
+
content_type;
90
+
cose = value;
91
+
payload_digest;
92
+
created_at = now;
93
+
}
94
+
in
95
+
let* json =
96
+
Json.encode Statement_lexicon.main_json record
97
+
|> Result.map_error Json.Error.to_string
98
+
in
99
+
let* dagcbor_value = Atp.Dagcbor.of_json json in
100
+
Ok (Atp.Dagcbor.encode_string dagcbor_value)
102
101
103
-
let size t = Hashtbl.length t.values
102
+
let size t = Hashtbl.length t.values
104
103
105
-
let root t =
106
-
match t.head with
107
-
| Some h -> Atp.Cid.to_string h
108
-
| None -> String.make 32 '\x00'
104
+
let root t =
105
+
match t.head with
106
+
| Some h -> Atp.Cid.to_string h
107
+
| None -> String.make 32 '\x00'
109
108
110
-
let err_duplicate key = Error ("duplicate key: " ^ key)
111
-
let err_encoding e = Error ("encoding error: " ^ e)
109
+
let err_duplicate key = Error ("duplicate key: " ^ key)
110
+
let err_encoding e = Error ("encoding error: " ^ e)
112
111
113
-
let repo_key_of_vds_key key =
114
-
match String.index_opt key '/' with
115
-
| Some i ->
116
-
let subject = String.sub key 0 i in
117
-
let issuer_fp = String.sub key (i + 1) (String.length key - i - 1) in
118
-
Ok (repo_key ~subject ~issuer_fp)
119
-
| None ->
120
-
Error
121
-
(Fmt.str "malformed VDS key %S: expected subject/issuer_fp format"
122
-
key)
112
+
let repo_key_of_vds_key key =
113
+
match String.index_opt key '/' with
114
+
| Some i ->
115
+
let subject = String.sub key 0 i in
116
+
let issuer_fp = String.sub key (i + 1) (String.length key - i - 1) in
117
+
Ok (repo_key ~subject ~issuer_fp)
118
+
| None ->
119
+
Error
120
+
(Fmt.str "malformed VDS key %S: expected subject/issuer_fp format" key)
123
121
124
-
let append ~now t ~key ~value =
125
-
if Hashtbl.mem t.values key then err_duplicate key
126
-
else
127
-
match repo_key_of_vds_key key with
128
-
| Error e -> Error e
129
-
| Ok rk -> (
130
-
match value_to_dagcbor ~now ~key value with
131
-
| Error e -> err_encoding e
132
-
| Ok dagcbor ->
133
-
(* Add record to MST via Atp.Mst *)
134
-
let bs = Atp.Blockstore.memory () in
135
-
let mst =
136
-
match S.head heap ~branch:"main" with
137
-
| Some tree_root ->
138
-
(* Copy blocks from heap to local blockstore *)
139
-
let rec copy_block cid =
140
-
match Irmin.Heap.find heap cid with
141
-
| Some data -> (
142
-
bs#put cid data;
143
-
(* Try to decode as MST node and copy subtrees *)
144
-
try
145
-
let node = Atp.Mst.Raw.decode_bytes data in
146
-
Option.iter copy_block node.l;
147
-
List.iter
148
-
(fun (e : Atp.Mst.Raw.entry) ->
149
-
Option.iter copy_block e.t)
150
-
node.e
151
-
with Invalid_argument _ | Failure _ -> ())
152
-
| None -> ()
153
-
in
154
-
copy_block tree_root;
155
-
Atp.Mst.of_cid tree_root
156
-
~store:(bs :> Atp.Blockstore.readable)
157
-
| None -> Atp.Mst.empty
158
-
in
159
-
(* Write the record blob *)
160
-
let record_cid = Atp.Cid.v `Dag_cbor dagcbor in
161
-
Irmin.Heap.put heap record_cid dagcbor;
162
-
bs#put record_cid dagcbor;
163
-
(* Add to MST *)
164
-
let mst = Atp.Mst.add rk record_cid mst ~store:bs in
165
-
let tree_root = Atp.Mst.to_cid mst ~store:bs in
166
-
(* Copy MST blocks back to heap *)
167
-
Atp.Mst.to_blocks mst ~store:(bs :> Atp.Blockstore.readable)
168
-
|> Seq.iter (fun (cid, data) -> Irmin.Heap.put heap cid data);
169
-
(* Update branch ref *)
170
-
S.set_head heap ~branch:"main" tree_root;
171
-
t.head <- Some tree_root;
172
-
Hashtbl.add t.values key value;
173
-
let leaf_hash = sha256 ("\x00" ^ value) in
174
-
(* Produce inclusion proof *)
175
-
let proof, _value =
176
-
S.produce heap repo_schema tree_root (fun c ->
177
-
match S.step_any c rk with
178
-
| Some (S.Step (sc, leaf)) ->
179
-
(S.Step (sc, leaf), S.get_block leaf)
180
-
| None -> (S.Step (repo_schema, c), None))
181
-
in
182
-
(* Encode proof as CBOR: [repo_key, [before, after, [[cid, block], ...]]] *)
183
-
let proof_cbor =
184
-
Cbor.Value.array
185
-
[
186
-
Cbor.Value.bytes (Atp.Cid.to_raw_bytes proof.before);
187
-
Cbor.Value.bytes (Atp.Cid.to_raw_bytes proof.after);
188
-
Cbor.Value.array
189
-
(List.map
190
-
(fun (cid, data) ->
191
-
Cbor.Value.array
192
-
[
193
-
Cbor.Value.bytes (Atp.Cid.to_raw_bytes cid);
194
-
Cbor.Value.bytes data;
195
-
])
196
-
(List.of_seq (Irmin.Heap.to_seq proof.heap)));
197
-
]
198
-
in
199
-
let encoded_proof = Cbor.encode_string Cbor.any proof_cbor in
200
-
let vdp_cbor =
201
-
Cbor.Value.array
202
-
[ Cbor.Value.string rk; Cbor.Value.bytes encoded_proof ]
203
-
in
204
-
let vdp_bytes = Cbor.encode_string Cbor.any vdp_cbor in
205
-
let root_raw = Atp.Cid.to_raw_bytes tree_root in
206
-
Ok
207
-
{
208
-
Scitt.leaf_index = 0;
209
-
tree_size = Hashtbl.length t.values;
210
-
root = root_raw;
211
-
path = [ vdp_bytes ];
212
-
leaf_hash;
213
-
})
122
+
let append ~now t ~key ~value =
123
+
if Hashtbl.mem t.values key then err_duplicate key
124
+
else
125
+
match repo_key_of_vds_key key with
126
+
| Error e -> Error e
127
+
| Ok rk -> (
128
+
match value_to_dagcbor ~now ~key value with
129
+
| Error e -> err_encoding e
130
+
| Ok dagcbor ->
131
+
(* Add record to MST via Atp.Mst *)
132
+
let bs = Atp.Blockstore.memory () in
133
+
let mst =
134
+
match S.head t.heap ~branch:"main" with
135
+
| Some tree_root ->
136
+
(* Copy blocks from heap to local blockstore *)
137
+
let rec copy_block cid =
138
+
match Irmin.Heap.find t.heap cid with
139
+
| Some data -> (
140
+
bs#put cid data;
141
+
(* Try to decode as MST node and copy subtrees *)
142
+
try
143
+
let node = Atp.Mst.Raw.decode_bytes data in
144
+
Option.iter copy_block node.l;
145
+
List.iter
146
+
(fun (e : Atp.Mst.Raw.entry) ->
147
+
Option.iter copy_block e.t)
148
+
node.e
149
+
with Invalid_argument _ | Failure _ -> ())
150
+
| None -> ()
151
+
in
152
+
copy_block tree_root;
153
+
Atp.Mst.of_cid tree_root
154
+
~store:(bs :> Atp.Blockstore.readable)
155
+
| None -> Atp.Mst.empty
156
+
in
157
+
(* Write the record blob *)
158
+
let record_cid = Atp.Cid.v `Dag_cbor dagcbor in
159
+
Irmin.Heap.put t.heap record_cid dagcbor;
160
+
bs#put record_cid dagcbor;
161
+
(* Add to MST *)
162
+
let mst = Atp.Mst.add rk record_cid mst ~store:bs in
163
+
let tree_root = Atp.Mst.to_cid mst ~store:bs in
164
+
(* Copy MST blocks back to heap *)
165
+
Atp.Mst.to_blocks mst ~store:(bs :> Atp.Blockstore.readable)
166
+
|> Seq.iter (fun (cid, data) -> Irmin.Heap.put t.heap cid data);
167
+
(* Update branch ref *)
168
+
S.set_head t.heap ~branch:"main" tree_root;
169
+
t.head <- Some tree_root;
170
+
Hashtbl.add t.values key value;
171
+
let leaf_hash = sha256 ("\x00" ^ value) in
172
+
(* Produce inclusion proof *)
173
+
let proof, _value =
174
+
S.produce t.heap repo_schema tree_root (fun c ->
175
+
match S.step_any c rk with
176
+
| Some (S.Step (sc, leaf)) ->
177
+
(S.Step (sc, leaf), S.get_block leaf)
178
+
| None -> (S.Step (repo_schema, c), None))
179
+
in
180
+
(* Encode proof as CBOR:
181
+
[repo_key, [before, after, [[cid, block], ...]]] *)
182
+
let proof_cbor =
183
+
Cbor.Value.array
184
+
[
185
+
Cbor.Value.bytes (Atp.Cid.to_raw_bytes proof.before);
186
+
Cbor.Value.bytes (Atp.Cid.to_raw_bytes proof.after);
187
+
Cbor.Value.array
188
+
(List.map
189
+
(fun (cid, data) ->
190
+
Cbor.Value.array
191
+
[
192
+
Cbor.Value.bytes (Atp.Cid.to_raw_bytes cid);
193
+
Cbor.Value.bytes data;
194
+
])
195
+
(List.of_seq (Irmin.Heap.to_seq proof.heap)));
196
+
]
197
+
in
198
+
let encoded_proof = Cbor.encode_string Cbor.any proof_cbor in
199
+
let vdp_cbor =
200
+
Cbor.Value.array
201
+
[ Cbor.Value.string rk; Cbor.Value.bytes encoded_proof ]
202
+
in
203
+
let vdp_bytes = Cbor.encode_string Cbor.any vdp_cbor in
204
+
let root_raw = Atp.Cid.to_raw_bytes tree_root in
205
+
Ok
206
+
{
207
+
Scitt.leaf_index = 0;
208
+
tree_size = Hashtbl.length t.values;
209
+
root = root_raw;
210
+
path = [ vdp_bytes ];
211
+
leaf_hash;
212
+
})
214
213
215
-
let lookup t ~key = Hashtbl.find_opt t.values key
214
+
let lookup t ~key = Hashtbl.find_opt t.values key
215
+
216
+
let export t =
217
+
Atp.Dagcbor.encode_string
218
+
(`Map
219
+
[
220
+
("algorithm", `Int (Int64.of_int (algorithm_id t)));
221
+
("root", `Bytes (root t));
222
+
("collection", `String collection);
223
+
("size", `Int (Int64.of_int (Hashtbl.length t.values)));
224
+
])
225
+
226
+
let v ~heap = { heap; head = None; values = Hashtbl.create 64 }
227
+
end
228
+
229
+
module Impl = struct
230
+
type t = { backend : Backend.t; now : unit -> (string, string) result }
231
+
232
+
let algorithm_id t = Backend.algorithm_id t.backend
233
+
let proof_format _ = Backend.proof_format
234
+
let append t ~key ~value = Backend.append ~now:t.now t.backend ~key ~value
235
+
let lookup t ~key = Backend.lookup t.backend ~key
236
+
let root t = Backend.root t.backend
237
+
let size t = Backend.size t.backend
238
+
239
+
let consistency _ ~first:_ =
240
+
Error "consistency proofs not supported for MST backend"
216
241
217
-
let export t =
218
-
Atp.Dagcbor.encode_string
219
-
(`Map
220
-
[
221
-
("algorithm", `Int (Int64.of_int (algorithm_id t)));
222
-
("root", `Bytes (root t));
223
-
("collection", `String collection);
224
-
("size", `Int (Int64.of_int (Hashtbl.length t.values)));
225
-
])
226
-
end in
227
-
let module Impl = struct
228
-
type nonrec t = {
229
-
backend : Backend.t;
230
-
now : unit -> (string, string) result;
231
-
}
242
+
let export t = Backend.export t.backend
232
243
233
-
let algorithm_id t = Backend.algorithm_id t.backend
234
-
let proof_format _ = Backend.proof_format
235
-
let append t ~key ~value = Backend.append ~now:t.now t.backend ~key ~value
236
-
let lookup t ~key = Backend.lookup t.backend ~key
237
-
let root t = Backend.root t.backend
238
-
let size t = Backend.size t.backend
244
+
let v ~heap ~clock =
245
+
let now () =
246
+
match Ptime.of_float_s (clock ()) with
247
+
| Some p -> Ok (Ptime.to_rfc3339 p)
248
+
| None -> Error "clock returned invalid time"
249
+
in
250
+
{ backend = Backend.v ~heap; now }
251
+
end
239
252
240
-
let consistency _ ~first:_ =
241
-
Error "consistency proofs not supported for MST backend"
253
+
module V = Scitt.Vds.Make (Impl)
242
254
243
-
let export t = Backend.export t.backend
244
-
end in
245
-
let now () =
246
-
match Ptime.of_float_s (clock ()) with
247
-
| Some p -> Ok (Ptime.to_rfc3339 p)
248
-
| None -> Error "clock returned invalid time"
249
-
in
250
-
let state =
251
-
Impl.{ backend = Backend.{ head = None; values = Hashtbl.create 64 }; now }
252
-
in
253
-
Scitt.Vds.v (module Impl) state
255
+
let v ~heap ~now:clock = V.v (Impl.v ~heap ~clock)
+57
-53
lib/vds.ml
+57
-53
lib/vds.ml
···
98
98
99
99
type t = T : { impl : (module S with type t = 'a); state : 'a } -> t
100
100
101
-
let v (type a) (impl : (module S with type t = a)) (state : a) =
102
-
T { impl; state }
101
+
module Make (B : S) = struct
102
+
let v (state : B.t) = T { impl = (module B); state }
103
+
end
103
104
104
105
let algorithm_id (T { impl = (module I); state }) = I.algorithm_id state
105
106
let proof_format (T { impl = (module I); state }) = I.proof_format state
···
388
389
in
389
390
let r = Compact.root t.compact ~empty_hash:t.empty_hash in
390
391
export_cbor ~hash:t.hash ~root:r ~entries)
392
+
393
+
let v ~hash ~max_entries =
394
+
let node_hash = Hash.node_hash_with hash in
395
+
let hashes = Growable.create ~max_entries 256 in
396
+
{
397
+
hash;
398
+
hashes;
399
+
compact = Compact.create node_hash;
400
+
ncache = Node_cache.v hash (Growable.get hashes);
401
+
leaves = Hashtbl.create 256;
402
+
leaves_order = [];
403
+
empty_hash = hash.Hash.digest "";
404
+
mu = Eio.Mutex.create ();
405
+
}
391
406
end
407
+
408
+
module V = Make (Impl)
392
409
393
410
let v ?(hash = Hash.sha256) ?(max_entries = 1_000_000) () =
394
-
let node_hash = Hash.node_hash_with hash in
395
-
let hashes = Growable.create ~max_entries 256 in
396
-
v
397
-
(module Impl)
398
-
Impl.
399
-
{
400
-
hash;
401
-
hashes;
402
-
compact = Compact.create node_hash;
403
-
ncache = Node_cache.v hash (Growable.get hashes);
404
-
leaves = Hashtbl.create 256;
405
-
leaves_order = [];
406
-
empty_hash = hash.Hash.digest "";
407
-
mu = Eio.Mutex.create ();
408
-
}
411
+
V.v (Impl.v ~hash ~max_entries)
409
412
end
410
413
411
414
(* -- Sqlite backend -- *)
···
488
491
Sqlite.Table.iter t.entries ~f:(fun k v -> all := (k, v) :: !all);
489
492
let r = Compact.root t.compact ~empty_hash:t.empty_hash in
490
493
export_cbor ~hash:t.hash ~root:r ~entries:(List.rev !all))
494
+
495
+
let v ~hash db =
496
+
(try
497
+
Sqlite.create_table db
498
+
~sql:
499
+
"CREATE TABLE scitt_hashes (id INTEGER PRIMARY KEY, hash BLOB NOT \
500
+
NULL)"
501
+
with Failure _ -> ());
502
+
let entries = Sqlite.Table.create db ~name:"scitt_entry" in
503
+
let node_hash = Hash.node_hash_with hash in
504
+
(* Count existing hashes and rebuild Compact by streaming — O(n) time,
505
+
O(log n) memory. No Growable array needed. *)
506
+
let entry_count = ref 0 in
507
+
let read_hash idx = get_hash db idx in
508
+
let compact =
509
+
let c = Compact.create node_hash in
510
+
Sqlite.fold_table db "scitt_hashes" ~init:() ~f:(fun _rowid values () ->
511
+
match values with
512
+
| [ Sqlite.Vblob h ] ->
513
+
Compact.append c h;
514
+
incr entry_count
515
+
| _ -> ());
516
+
c
517
+
in
518
+
{
519
+
db;
520
+
hash;
521
+
entries;
522
+
empty_hash = hash.Hash.digest "";
523
+
entry_count = !entry_count;
524
+
compact;
525
+
ncache = Node_cache.v hash read_hash;
526
+
mu = Eio.Mutex.create ();
527
+
}
491
528
end
492
529
493
-
let v ?(hash = Hash.sha256) (db : Sqlite.t) =
494
-
(try
495
-
Sqlite.create_table db
496
-
~sql:
497
-
"CREATE TABLE scitt_hashes (id INTEGER PRIMARY KEY, hash BLOB NOT \
498
-
NULL)"
499
-
with Failure _ -> ());
500
-
let entries = Sqlite.Table.create db ~name:"scitt_entry" in
501
-
let node_hash = Hash.node_hash_with hash in
502
-
(* Count existing hashes and rebuild Compact by streaming — O(n) time,
503
-
O(log n) memory. No Growable array needed. *)
504
-
let entry_count = ref 0 in
505
-
let read_hash idx = Impl.get_hash db idx in
506
-
let compact =
507
-
let c = Compact.create node_hash in
508
-
Sqlite.fold_table db "scitt_hashes" ~init:() ~f:(fun _rowid values () ->
509
-
match values with
510
-
| [ Sqlite.Vblob h ] ->
511
-
Compact.append c h;
512
-
incr entry_count
513
-
| _ -> ());
514
-
c
515
-
in
516
-
v
517
-
(module Impl)
518
-
Impl.
519
-
{
520
-
db;
521
-
hash;
522
-
entries;
523
-
empty_hash = hash.Hash.digest "";
524
-
entry_count = !entry_count;
525
-
compact;
526
-
ncache = Node_cache.v hash read_hash;
527
-
mu = Eio.Mutex.create ();
528
-
}
530
+
module V = Make (Impl)
531
+
532
+
let v ?(hash = Hash.sha256) db = V.v (Impl.v ~hash db)
529
533
end
530
534
531
535
(* -- Import -- *)
+6
-2
lib/vds.mli
+6
-2
lib/vds.mli
···
67
67
type t
68
68
(** A verifiable data structure. *)
69
69
70
-
val v : (module S with type t = 'a) -> 'a -> t
71
-
(** [v impl state] wraps a backend implementation. *)
70
+
module Make (B : S) : sig
71
+
val v : B.t -> t
72
+
(** [v state] wraps [state] of backend [B] as an opaque {!t}. Call it at
73
+
module level — each backend applies [Make] once against its own [Impl] and
74
+
then exposes a type-erased [t] through [v]. *)
75
+
end
72
76
73
77
val algorithm_id : t -> int
74
78
(** [algorithm_id t] is the hash algorithm identifier. *)