Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
irmin: adapt ocaml-scitt to new Schema API — 13/20 tests pass
+143
-161
+98
-60
lib/atp/scitt_atp.ml
+98
-60
lib/atp/scitt_atp.ml
···
1
1
(* AT Proto MST backend for SCITT.
2
2
3
-
Uses an Irmin store for persistence. Each append creates an Irmin
4
-
commit, preserving the full history of the transparency log. Inclusion
5
-
proofs are generated from the MST tree structure via Irmin.Proof.
6
-
7
-
The store can be backed by any Irmin backend: in-memory MST for tests,
8
-
on-disk MST for production, or an ATProto PDS via Irmin.Atproto.of_pds.
9
-
10
-
MST keys follow AT Proto convention: collection/rkey
11
-
- Collection: "space.run.scitt.statement"
12
-
- Record key: hex-encoded composite of subject and issuer fingerprint *)
3
+
Uses a content-addressed heap with the Irmin Schema API. Each append
4
+
writes a record to the MST, creates a commit block, and updates the
5
+
branch ref. Inclusion proofs are generated via Schema.produce. *)
13
6
14
7
let sha256 s = Digestif.SHA256.(digest_string s |> to_raw_string)
15
8
let collection = "space.run.scitt.statement"
···
30
23
31
24
module Statement_lexicon = Atp_lexicon_scitt.Space.Run.Scitt.Statement
32
25
33
-
module type Config = sig
34
-
val store : Irmin.t
35
-
(** The Irmin store. Use [Irmin.Atproto.memory ()] for tests,
36
-
[Irmin.Atproto.of_pds pds] for production. *)
26
+
(* ATProto MST schema instance *)
27
+
module S = Irmin.Schema.Make (struct
28
+
type hash = Atp.Cid.t
29
+
type block = string
30
+
31
+
let hash_equal = Atp.Cid.equal
32
+
let hash_block data = Atp.Cid.v `Dag_cbor data
33
+
end)
34
+
35
+
(* MST parse: decode DAG-CBOR MST node, extract entries *)
36
+
let mst_parse : S.parse =
37
+
fun data ->
38
+
try
39
+
let node = Atp.Mst.Raw.decode_bytes data in
40
+
let rec decompress prev = function
41
+
| [] -> []
42
+
| (e : Atp.Mst.Raw.entry) :: rest ->
43
+
let key = String.sub prev 0 e.p ^ e.k in
44
+
(key, (`Link e.v : S.child)) :: decompress key rest
45
+
in
46
+
S.Named (decompress "" node.e)
47
+
with _ -> S.Named []
48
+
49
+
let mst_serialize : S.serialize =
50
+
fun _children ->
51
+
(* TODO: proper MST serialization *)
52
+
""
37
53
54
+
let mst_node rules = S.node ~parse:mst_parse ~serialize:mst_serialize rules
55
+
let ( => ) = S.( => )
56
+
let repo_schema = S.fix (fun _self -> mst_node [ "*" => S.opaque ])
57
+
58
+
module type Config = sig
59
+
val heap : (Atp.Cid.t, string, unit) Irmin.Heap.t
38
60
val now : unit -> float
39
61
end
40
62
41
63
module Make (C : Config) = struct
42
64
module Backend = struct
43
65
type t = {
44
-
mutable head : Irmin.hash option;
66
+
mutable head : Atp.Cid.t option;
45
67
values : (string, string) Hashtbl.t;
46
68
}
47
69
···
81
103
82
104
let root t =
83
105
match t.head with
84
-
| Some h -> Irmin.Hash.to_hex h
106
+
| Some h -> Atp.Cid.to_string h
85
107
| None -> String.make 32 '\x00'
86
108
87
109
let err_duplicate key = Error ("duplicate key: " ^ key)
···
106
128
| Ok rk -> (
107
129
match value_to_dagcbor ~now ~key value with
108
130
| Error e -> err_encoding e
109
-
| Ok dagcbor -> (
110
-
let tree =
111
-
match Irmin.checkout C.store ~branch:"main" with
112
-
| Some t -> t
113
-
| None -> Irmin.Tree.empty
114
-
in
115
-
let tree = Irmin.Tree.add tree [ rk ] dagcbor in
116
-
let parents =
117
-
match Irmin.head C.store ~branch:"main" with
118
-
| Some h -> [ h ]
119
-
| None -> []
120
-
in
121
-
let h =
122
-
Irmin.commit C.store ~tree ~parents
123
-
~message:(Fmt.str "append %s" key) ~author:"scitt"
131
+
| Ok dagcbor ->
132
+
(* Add record to MST via Atp.Mst *)
133
+
let bs = Atp.Blockstore.memory () in
134
+
let mst =
135
+
match S.head C.heap ~branch:"main" with
136
+
| Some tree_root ->
137
+
(* Copy blocks from heap to local blockstore *)
138
+
let rec copy_block cid =
139
+
match Irmin.Heap.get C.heap cid with
140
+
| Some data -> (
141
+
bs#put cid data;
142
+
(* Try to decode as MST node and copy subtrees *)
143
+
try
144
+
let node = Atp.Mst.Raw.decode_bytes data in
145
+
Option.iter copy_block node.l;
146
+
List.iter
147
+
(fun (e : Atp.Mst.Raw.entry) ->
148
+
Option.iter copy_block e.t)
149
+
node.e
150
+
with _ -> ())
151
+
| None -> ()
152
+
in
153
+
copy_block tree_root;
154
+
Atp.Mst.of_cid tree_root
155
+
~store:(bs :> Atp.Blockstore.readable)
156
+
| None -> Atp.Mst.empty
124
157
in
125
-
Irmin.set_head C.store ~branch:"main" h;
126
-
t.head <- Some h;
158
+
(* Write the record blob *)
159
+
let record_cid = Atp.Cid.v `Dag_cbor dagcbor in
160
+
Irmin.Heap.put C.heap record_cid dagcbor;
161
+
bs#put record_cid dagcbor;
162
+
(* Add to MST *)
163
+
let mst = Atp.Mst.add rk record_cid mst ~store:bs in
164
+
let tree_root = Atp.Mst.to_cid mst ~store:bs in
165
+
(* Copy MST blocks back to heap *)
166
+
Atp.Mst.to_blocks mst ~store:(bs :> Atp.Blockstore.readable)
167
+
|> Seq.iter (fun (cid, data) -> Irmin.Heap.put C.heap cid data);
168
+
(* Update branch ref *)
169
+
S.set_head C.heap ~branch:"main" tree_root;
170
+
t.head <- Some tree_root;
127
171
Hashtbl.add t.values key value;
128
172
let leaf_hash = sha256 ("\x00" ^ value) in
129
-
(* Produce an inclusion proof and encode as [repo_key, proof]
130
-
CBOR array for the vdp receipt field. The tree root is the
131
-
hash of the committed tree (distinct from the commit hash). *)
132
-
let tree_root =
133
-
match Irmin.tree_hash C.store h with
134
-
| Some th -> th
135
-
| None -> h
173
+
(* Produce inclusion proof *)
174
+
let proof, _value =
175
+
S.produce C.heap repo_schema tree_root (fun c ->
176
+
match S.step c rk with
177
+
| Some (S.Any leaf) -> (S.Any leaf, S.get leaf)
178
+
| None -> (S.Any c, None))
179
+
in
180
+
ignore proof;
181
+
(* For now, encode proof as empty — proper CBOR encoding TODO *)
182
+
let vdp_cbor =
183
+
Cbort.Cbor.array [ Cbort.Cbor.string rk; Cbort.Cbor.bytes "" ]
136
184
in
137
-
match Irmin.prove C.store ~tree_root ~key:rk with
138
-
| Error e -> Error ("prove: " ^ e)
139
-
| Ok (encoded_proof, _value) ->
140
-
let vdp_cbor =
141
-
Cbort.Cbor.array
142
-
[ Cbort.Cbor.string rk; Cbort.Cbor.bytes encoded_proof ]
143
-
in
144
-
let vdp_bytes = Cbort.encode_string Cbort.any vdp_cbor in
145
-
let root_raw =
146
-
Atp.Cid.to_raw_bytes
147
-
(Atp.Cid.of_string (Irmin.Hash.to_hex tree_root))
148
-
in
149
-
Ok
150
-
{
151
-
Scitt.leaf_index = 0;
152
-
tree_size = Hashtbl.length t.values;
153
-
root = root_raw;
154
-
path = [ vdp_bytes ];
155
-
leaf_hash;
156
-
}))
185
+
let vdp_bytes = Cbort.encode_string Cbort.any vdp_cbor in
186
+
let root_raw = Atp.Cid.to_raw_bytes tree_root in
187
+
Ok
188
+
{
189
+
Scitt.leaf_index = 0;
190
+
tree_size = Hashtbl.length t.values;
191
+
root = root_raw;
192
+
path = [ vdp_bytes ];
193
+
leaf_hash;
194
+
})
157
195
158
196
let lookup t ~key = Hashtbl.find_opt t.values key
159
197
+13
-44
lib/atp/scitt_atp.mli
+13
-44
lib/atp/scitt_atp.mli
···
1
1
(** AT Proto MST backend for SCITT.
2
2
3
-
Implements a {!Scitt.vds} using an Irmin store backed by the AT Protocol
4
-
Merkle Search Tree. Each append creates an Irmin commit, preserving the full
5
-
transparency log history. The MST provides SHA-256 content addressing with
6
-
key-based lookup.
7
-
8
-
{2 Advantages over RFC 9162}
9
-
10
-
- **Key-based lookup**: [Scitt.vds_lookup vds ~key:"sha256:abc"] is O(log
11
-
n), not O(n).
12
-
- **Richer proofs**: inclusion proof covers a specific key, not just an
13
-
index position.
14
-
- **AT Proto compatible**: the tree format is interoperable with AT Protocol
15
-
repositories (Bluesky, Tangled, etc.).
16
-
- **Full history**: every append is an Irmin commit; the log is auditable.
17
-
18
-
{2 Example}
3
+
Implements a {!Scitt.vds} using a content-addressed heap backed by the AT
4
+
Protocol Merkle Search Tree. Each append writes a record to the MST and
5
+
updates the branch ref.
19
6
20
7
{[
21
-
let store = Irmin.Mst.memory () in
22
-
let module V = Scitt_atp.Make (struct let store = store let now () = Unix.gettimeofday () end) in
23
-
let vds = V.v () in
24
-
(* ... same API as with Vds_rfc9162 ... *)
25
-
]}
26
-
27
-
For production with ATProto PDS persistence:
28
-
29
-
{[
30
-
let pds = Pds.v ~sw path ~did in
31
-
let store = Irmin.Mst.of_pds pds in
32
-
(* ... same as above ... *)
33
-
]}
34
-
35
-
{2 References}
36
-
37
-
- {{:https://atproto.com/specs/repository#mst-structure}AT Proto MST Spec}
38
-
- {{:https://atproto.com/specs/data-model}AT Proto Data Model (DAG-CBOR)} *)
8
+
let module Heap_b = Irmin.Heap.Make (...) in
9
+
let heap = Heap_b.v (Atp.Blockstore.memory ()) in
10
+
let module V = Scitt_atp.Make (struct
11
+
let heap = heap
12
+
let now () = Unix.gettimeofday ()
13
+
end) in
14
+
let vds = V.v ()
15
+
]} *)
39
16
40
17
(** Configuration for the MST backend. *)
41
18
module type Config = sig
42
-
val store : Irmin.t
43
-
(** The Irmin store. Use [Irmin.Mst.memory ()] for tests,
44
-
[Irmin.Mst.of_pds pds] for ATProto PDS persistence, or
45
-
[Irmin.Mst.disk ~sw root] for standalone on-disk storage. *)
19
+
val heap : (Atp.Cid.t, string, unit) Irmin.Heap.t
20
+
(** The heap. *)
46
21
47
22
val now : unit -> float
48
23
(** Clock for record timestamps. *)
49
24
end
50
25
51
-
(** [Make (Config)] creates a module that produces {!Scitt.vds} values backed by
52
-
the AT Proto MST, persisted to the configured Irmin store.
53
-
54
-
Algorithm ID: -65537 (private use per draft-ietf-cose-merkle-tree-proofs
55
-
§10.3). *)
56
26
module Make (C : Config) : sig
57
27
val v : unit -> Scitt.vds
58
-
(** [v ()] creates a fresh AT Proto MST-backed VDS. *)
59
28
end
+5
-56
lib/proof.ml
+5
-56
lib/proof.ml
···
68
68
| _ -> None)
69
69
| _ -> None
70
70
71
-
(** Verify an Irmin proof against [root] and check the cose leaf hash. *)
72
-
let verify_irmin_proof ~hash ~expected_leaf ~root ~repo_key irmin_proof =
73
-
match Atp.Cid.of_raw_bytes root with
74
-
| exception (Invalid_argument _ | Failure _) ->
75
-
Error "MST proof: malformed root CID"
76
-
| expected_root -> (
77
-
let expected_root = `Node expected_root in
78
-
match
79
-
Irmin.Proof.Mst.verify ~expected_root irmin_proof (fun tree ->
80
-
let v = Irmin.Proof.Mst.Tree.find tree [ repo_key ] in
81
-
(tree, v))
82
-
with
83
-
| exception (Eio.Io _ | Invalid_argument _ | Failure _ | Z.Overflow) ->
84
-
Error "MST proof verify: malformed data"
85
-
| Ok (_, Some dagcbor) -> (
86
-
match extract_cose dagcbor with
87
-
| Some cose ->
88
-
let leaf = hash.Hash.digest ("\x00" ^ cose) in
89
-
if Eqaf.equal leaf expected_leaf then Ok Merkle_proof
90
-
else Error "MST proof: cose leaf hash mismatch"
91
-
| None -> Error "MST proof: cannot extract cose from record")
92
-
| Ok (_, None) -> Error "MST proof: key not in tree"
93
-
| Error (`Proof_mismatch msg) -> Error ("MST proof mismatch: " ^ msg))
71
+
(** Verify an MST inclusion proof.
94
72
95
-
let verify_mst ~hash ~expected_leaf ~expected_repo_key ~root path =
96
-
match path with
97
-
| [ vdp_data ] -> (
98
-
match Cbort.decode_string Cbort.any vdp_data with
99
-
| Error _ -> Error "MST vdp: invalid CBOR"
100
-
| Ok vdp_cbor -> (
101
-
match Cbort.Cbor.to_array vdp_cbor with
102
-
| Some [ key_cbor; proof_cbor ] -> (
103
-
let repo_key =
104
-
Option.value ~default:"" (Cbort.Cbor.to_text key_cbor)
105
-
in
106
-
(* Verify the proof's repo_key matches the expected key
107
-
derived from the statement's subject. Without this, a
108
-
malicious TS can store the COSE blob under any key. *)
109
-
if not (Eqaf.equal repo_key expected_repo_key) then
110
-
Error "MST proof repo_key mismatch"
111
-
else
112
-
let irmin_proof_bytes =
113
-
Option.value ~default:"" (Cbort.Cbor.to_bytes proof_cbor)
114
-
in
115
-
match
116
-
Irmin.Proof.decode_cbor ~decode_hash:Atp.Cid.of_raw_bytes
117
-
~decode_contents:Fun.id irmin_proof_bytes
118
-
with
119
-
| exception
120
-
(Eio.Io _ | Invalid_argument _ | Failure _ | Z.Overflow) ->
121
-
Error "MST proof decode: malformed data"
122
-
| Error (`Msg msg) -> Error ("MST proof decode: " ^ msg)
123
-
| Ok irmin_proof ->
124
-
verify_irmin_proof ~hash ~expected_leaf ~root ~repo_key
125
-
irmin_proof)
126
-
| _ -> Error "MST vdp must be [repo_key, proof_cbor]"))
127
-
| _ -> Error "MST receipt must have exactly one proof entry"
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"
+1
test/atp/dune
+1
test/atp/dune
+26
-1
test/atp/test_scitt_atp.ml
+26
-1
test/atp/test_scitt_atp.ml
···
40
40
41
41
(* -- Test MST module: fresh in-memory blockstore per instance -- *)
42
42
43
+
module Atp_heap_backend :
44
+
Irmin.Heap.BACKEND
45
+
with type t = Atp.Blockstore.writable
46
+
and type hash = Atp.Cid.t
47
+
and type block = string = struct
48
+
type t = Atp.Blockstore.writable
49
+
type hash = Atp.Cid.t
50
+
type block = string
51
+
52
+
let get (bs : t) h = bs#get h
53
+
let put (bs : t) h data = bs#put h data
54
+
let mem (bs : t) h = bs#has h
55
+
let batch bs l = List.iter (fun (h, d) -> bs#put h d) l
56
+
let get_ref _ _ = None
57
+
let set_ref _ _ _ = ()
58
+
let del_ref _ _ = ()
59
+
let list_refs _ = []
60
+
let cas_ref _ _ ~test:_ ~set:_ = false
61
+
let flush _ = ()
62
+
let close _ = ()
63
+
end
64
+
65
+
module Atp_heap = Irmin.Heap.Make (Atp_heap_backend)
66
+
43
67
let vds_mst () =
44
68
let clock = mock_clock () in
69
+
let heap = Atp_heap.v (Atp.Blockstore.memory ()) in
45
70
let module C = struct
46
-
let store = Irmin.Atproto.(memory () |> v)
71
+
let heap = heap
47
72
let now () = Eio.Time.now clock
48
73
end in
49
74
let module V = Scitt_atp.Make (C) in