Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: further merlint cleanup
- bin/cmd_proof: split the grouped subcommand into cmd_proof_produce,
cmd_proof_verify, and a cmd_proof_shared helper module (E524 for
sub-subcommands).
- bin/cmd_checkout: rename create_flag back to flag (E331 redundant
prefix); the inner Arg.flag resolves inside Arg.(...) and doesn't
conflict with the outer let.
- bin/cmd_serve: rename find_invalid_filename to invalid_filename (E331).
- test/helpers: move to test/helpers/ as its own private library so the
test stanza only contains test_ files (E618), and add a module-level
doc comment (E400).
+237
-220
+2
-2
bin/cmd_checkout.ml
+2
-2
bin/cmd_checkout.ml
···
33
33
let doc = "Branch to checkout or create." in
34
34
Arg.(required & pos 0 (some string) None & info [] ~docv:"BRANCH" ~doc)
35
35
36
-
let create_flag =
36
+
let flag =
37
37
let doc = "Create a new branch." in
38
38
Arg.(value & flag & info [ "c"; "create" ] ~doc)
39
39
···
50
50
(Cmd.info "checkout" ~doc ~man)
51
51
Term.(
52
52
const (fun () repo create branch -> ignore (run ~repo ~create branch))
53
-
$ Terms.setup $ Terms.repo $ create_flag $ checkout_branch)
53
+
$ Terms.setup $ Terms.repo $ flag $ checkout_branch)
+3
-216
bin/cmd_proof.ml
+3
-216
bin/cmd_proof.ml
···
1
-
(** Proof commands.
2
-
3
-
Builds an in-memory SHA-256 Merkle tree from KEY=VALUE args, then
4
-
produce/verify a proof. Does not depend on any backend library -- uses
5
-
Irmin.SHA256 directly with a flat tree (each key is a direct child of the
6
-
root). *)
7
-
8
-
module S = Irmin.SHA256
9
-
10
-
(* Flat tree: children are all leaves stored as Link hashes. *)
11
-
12
-
let hash_size = 32
13
-
14
-
let dir_serialize : S.enc = function
15
-
| S.Named entries ->
16
-
let buf = Buffer.create 256 in
17
-
List.iter
18
-
(fun (name, child) ->
19
-
Buffer.add_string buf name;
20
-
Buffer.add_char buf '\x00';
21
-
match child with
22
-
| `Link h -> Buffer.add_string buf (Digestif.SHA256.to_raw_string h)
23
-
| `Inline data ->
24
-
Buffer.add_string buf
25
-
(Digestif.SHA256.to_raw_string
26
-
(Digestif.SHA256.digest_string data)))
27
-
entries;
28
-
Buffer.contents buf
29
-
| S.Indexed _ -> ""
30
-
31
-
let dir_parse data : S.children =
32
-
let len = String.length data in
33
-
let rec loop pos acc =
34
-
if pos >= len then S.Named (List.rev acc)
35
-
else
36
-
match String.index_from_opt data pos '\x00' with
37
-
| None -> S.Named (List.rev acc)
38
-
| Some null_pos ->
39
-
let name = String.sub data pos (null_pos - pos) in
40
-
let hash_start = null_pos + 1 in
41
-
if hash_start + hash_size > len then S.Named (List.rev acc)
42
-
else
43
-
let hash_bytes = String.sub data hash_start hash_size in
44
-
let h = Digestif.SHA256.of_raw_string hash_bytes in
45
-
loop (hash_start + hash_size) ((name, `Link h) :: acc)
46
-
in
47
-
loop 0 []
48
-
49
-
let ( => ) = S.( => )
50
-
51
-
let tree =
52
-
S.fix (fun self ->
53
-
S.node ~name:"application/x-flat-tree" ~dec:dir_parse ~enc:dir_serialize
54
-
~rules:[ "*" => self ]
55
-
())
56
-
57
-
(** Build a flat tree from key=value pairs. Each key is a direct child of the
58
-
root; values are stored as blobs. *)
59
-
let build_tree (heap : (Digestif.SHA256.t, string) Irmin.Heap.t)
60
-
(entries : (string * string) list) : Digestif.SHA256.t =
61
-
let children =
62
-
List.map
63
-
(fun (k, v) ->
64
-
let h = Digestif.SHA256.digest_string v in
65
-
Irmin.Heap.put heap h v;
66
-
(k, (`Link h : S.child)))
67
-
entries
68
-
in
69
-
let sorted = List.sort (fun (a, _) (b, _) -> String.compare a b) children in
70
-
let block = dir_serialize (S.Named sorted) in
71
-
let h = Digestif.SHA256.digest_string block in
72
-
Irmin.Heap.put heap h block;
73
-
h
74
-
75
-
(** In-memory mutable heap backed by a Hashtbl. *)
76
-
module Mem_backend :
77
-
Irmin.Heap.BACKEND
78
-
with type t = (string, string) Hashtbl.t
79
-
and type hash = Digestif.SHA256.t
80
-
and type block = string = struct
81
-
type t = (string, string) Hashtbl.t
82
-
type hash = Digestif.SHA256.t
83
-
type block = string
84
-
85
-
let key h = Digestif.SHA256.to_raw_string h
86
-
let find tbl h = Hashtbl.find_opt tbl (key h)
87
-
let put tbl h data = Hashtbl.replace tbl (key h) data
88
-
let mem tbl h = Hashtbl.mem tbl (key h)
89
-
let batch tbl l = List.iter (fun (h, data) -> put tbl h data) l
90
-
let ref _ _ = None
91
-
let set_ref _ _ _ = ()
92
-
let del_ref _ _ = ()
93
-
let list_refs _ = []
94
-
let cas_ref _ _ ~test:_ ~set:_ = false
95
-
let flush _ = ()
96
-
let close _ = ()
97
-
end
98
-
99
-
module Mem_heap = Irmin.Heap.Make (Mem_backend)
100
-
101
-
let memory_heap () = Mem_heap.v (Hashtbl.create 64)
102
-
103
-
let parse_entries data =
104
-
List.filter_map
105
-
(fun line ->
106
-
match String.index_opt line '=' with
107
-
| None -> None
108
-
| Some i ->
109
-
let k = String.sub line 0 i in
110
-
let v = String.sub line (i + 1) (String.length line - i - 1) in
111
-
Some (k, v))
112
-
data
113
-
114
-
let produce ~output ~key data =
115
-
let entries = parse_entries data in
116
-
let heap = memory_heap () in
117
-
let root = build_tree heap entries in
118
-
let proof, result =
119
-
S.produce heap tree root (fun c ->
120
-
let v = S.find c [ key ] in
121
-
(S.Step (tree, c), v))
122
-
in
123
-
let hash_str h =
124
-
let hex = Digestif.SHA256.to_hex h in
125
-
String.sub hex 0 (min 16 (String.length hex))
126
-
in
127
-
let before_hash = hash_str proof.before in
128
-
let after_hash = hash_str proof.after in
129
-
(match output with
130
-
| `Human ->
131
-
Fmt.pr "Root: %s@." (hash_str root);
132
-
Fmt.pr "Key: %s@." key;
133
-
Fmt.pr "Value: %s@." (Option.value ~default:"<not found>" result);
134
-
Fmt.pr "Before: %s@." before_hash;
135
-
Fmt.pr "After: %s@." after_hash
136
-
| `Json ->
137
-
Fmt.pr {|{"root":%S,"key":%S,"value":%s,"before":%S,"after":%S}@.|}
138
-
(Digestif.SHA256.to_hex root)
139
-
key
140
-
(match result with Some v -> Fmt.str "%S" v | None -> "null")
141
-
before_hash after_hash);
142
-
0
143
-
144
-
let verify ~output ~key data =
145
-
let entries = parse_entries data in
146
-
let heap = memory_heap () in
147
-
let root = build_tree heap entries in
148
-
let proof, _ =
149
-
S.produce heap tree root (fun c ->
150
-
let v = S.find c [ key ] in
151
-
(S.Step (tree, c), v))
152
-
in
153
-
match
154
-
S.verify proof tree (fun c ->
155
-
let v = S.find c [ key ] in
156
-
(S.Step (tree, c), v))
157
-
with
158
-
| Ok v ->
159
-
(match output with
160
-
| `Human ->
161
-
Common.success "Verified: %s" (Option.value ~default:"<none>" v)
162
-
| `Json ->
163
-
Fmt.pr {|{"verified":true,"value":%s}@.|}
164
-
(match v with Some x -> Fmt.str "%S" x | None -> "null"));
165
-
0
166
-
| Error (`Proof_failure msg) ->
167
-
(match output with
168
-
| `Human -> Common.error "Invalid: %s" msg
169
-
| `Json -> Fmt.pr {|{"verified":false,"error":%S}@.|} msg);
170
-
1
1
+
(** [irmin proof] group: MST Merkle proof produce/verify. *)
171
2
172
3
open Cmdliner
173
4
174
-
let proof_key =
175
-
let doc = "Key to produce/verify proof for." in
176
-
Arg.(required & opt (some string) None & info [ "k"; "key" ] ~docv:"KEY" ~doc)
177
-
178
-
let proof_data =
179
-
let doc = "Data entries as KEY=VALUE." in
180
-
Arg.(value & pos_all string [] & info [] ~docv:"KEY=VALUE" ~doc)
181
-
182
-
let produce_cmd : unit Cmd.t =
183
-
let doc = "Produce a Merkle proof for a key." in
184
-
let man =
185
-
[
186
-
`S Manpage.s_description;
187
-
`P
188
-
"Produces a Merkle proof for reading a key from an MST (Merkle Search \
189
-
Tree). The proof contains only the data needed to verify the read.";
190
-
`S Manpage.s_examples;
191
-
`Pre " irmin proof produce -k mykey foo=bar baz=qux";
192
-
`Pre " irmin proof produce -k post/123 -o json 'post/123=Hello'";
193
-
]
194
-
in
195
-
Cmd.v
196
-
(Cmd.info "produce" ~doc ~man)
197
-
Term.(
198
-
const (fun () output key data -> ignore (produce ~output ~key data))
199
-
$ Terms.setup $ Terms.output $ proof_key $ proof_data)
200
-
201
-
let verify_cmd : unit Cmd.t =
202
-
let doc = "Verify a Merkle proof for a key." in
203
-
let man =
204
-
[
205
-
`S Manpage.s_description;
206
-
`P
207
-
"Verifies that a Merkle proof correctly proves a read operation. \
208
-
Returns exit code 0 if valid, 1 if invalid.";
209
-
`S Manpage.s_examples;
210
-
`Pre " irmin proof verify -k mykey foo=bar baz=qux";
211
-
]
212
-
in
213
-
Cmd.v
214
-
(Cmd.info "verify" ~doc ~man)
215
-
Term.(
216
-
const (fun () output key data -> ignore (verify ~output ~key data))
217
-
$ Terms.setup $ Terms.output $ proof_key $ proof_data)
218
-
219
5
let cmd : unit Cmd.t =
220
6
let doc = "MST Merkle proofs (ATProto-compatible)." in
221
7
let man =
···
227
13
`P "Proofs allow verifying tree operations without full data access.";
228
14
]
229
15
in
230
-
Cmd.group (Cmd.info "proof" ~doc ~man) [ produce_cmd; verify_cmd ]
16
+
Cmd.group (Cmd.info "proof" ~doc ~man)
17
+
[ Cmd_proof_produce.cmd; Cmd_proof_verify.cmd ]
+55
bin/cmd_proof_produce.ml
+55
bin/cmd_proof_produce.ml
···
1
+
(** Proof produce subcommand. *)
2
+
3
+
module S = Cmd_proof_shared.S
4
+
5
+
let run ~output ~key data =
6
+
let entries = Cmd_proof_shared.parse_entries data in
7
+
let heap = Cmd_proof_shared.memory_heap () in
8
+
let root = Cmd_proof_shared.build_tree heap entries in
9
+
let proof, result =
10
+
S.produce heap Cmd_proof_shared.tree root (fun c ->
11
+
let v = S.find c [ key ] in
12
+
(S.Step (Cmd_proof_shared.tree, c), v))
13
+
in
14
+
let hash_str h =
15
+
let hex = Digestif.SHA256.to_hex h in
16
+
String.sub hex 0 (min 16 (String.length hex))
17
+
in
18
+
let before_hash = hash_str proof.before in
19
+
let after_hash = hash_str proof.after in
20
+
(match output with
21
+
| `Human ->
22
+
Fmt.pr "Root: %s@." (hash_str root);
23
+
Fmt.pr "Key: %s@." key;
24
+
Fmt.pr "Value: %s@." (Option.value ~default:"<not found>" result);
25
+
Fmt.pr "Before: %s@." before_hash;
26
+
Fmt.pr "After: %s@." after_hash
27
+
| `Json ->
28
+
Fmt.pr {|{"root":%S,"key":%S,"value":%s,"before":%S,"after":%S}@.|}
29
+
(Digestif.SHA256.to_hex root)
30
+
key
31
+
(match result with Some v -> Fmt.str "%S" v | None -> "null")
32
+
before_hash after_hash);
33
+
0
34
+
35
+
open Cmdliner
36
+
37
+
let cmd : unit Cmd.t =
38
+
let doc = "Produce a Merkle proof for a key." in
39
+
let man =
40
+
[
41
+
`S Manpage.s_description;
42
+
`P
43
+
"Produces a Merkle proof for reading a key from an MST (Merkle Search \
44
+
Tree). The proof contains only the data needed to verify the read.";
45
+
`S Manpage.s_examples;
46
+
`Pre " irmin proof produce -k mykey foo=bar baz=qux";
47
+
`Pre " irmin proof produce -k post/123 -o json 'post/123=Hello'";
48
+
]
49
+
in
50
+
Cmd.v
51
+
(Cmd.info "produce" ~doc ~man)
52
+
Term.(
53
+
const (fun () output key data -> ignore (run ~output ~key data))
54
+
$ Terms.setup $ Terms.output $ Cmd_proof_shared.proof_key
55
+
$ Cmd_proof_shared.proof_data)
+52
bin/cmd_proof_verify.ml
+52
bin/cmd_proof_verify.ml
···
1
+
(** Proof verify subcommand. *)
2
+
3
+
module S = Cmd_proof_shared.S
4
+
5
+
let run ~output ~key data =
6
+
let entries = Cmd_proof_shared.parse_entries data in
7
+
let heap = Cmd_proof_shared.memory_heap () in
8
+
let root = Cmd_proof_shared.build_tree heap entries in
9
+
let proof, _ =
10
+
S.produce heap Cmd_proof_shared.tree root (fun c ->
11
+
let v = S.find c [ key ] in
12
+
(S.Step (Cmd_proof_shared.tree, c), v))
13
+
in
14
+
match
15
+
S.verify proof Cmd_proof_shared.tree (fun c ->
16
+
let v = S.find c [ key ] in
17
+
(S.Step (Cmd_proof_shared.tree, c), v))
18
+
with
19
+
| Ok v ->
20
+
(match output with
21
+
| `Human ->
22
+
Common.success "Verified: %s" (Option.value ~default:"<none>" v)
23
+
| `Json ->
24
+
Fmt.pr {|{"verified":true,"value":%s}@.|}
25
+
(match v with Some x -> Fmt.str "%S" x | None -> "null"));
26
+
0
27
+
| Error (`Proof_failure msg) ->
28
+
(match output with
29
+
| `Human -> Common.error "Invalid: %s" msg
30
+
| `Json -> Fmt.pr {|{"verified":false,"error":%S}@.|} msg);
31
+
1
32
+
33
+
open Cmdliner
34
+
35
+
let cmd : unit Cmd.t =
36
+
let doc = "Verify a Merkle proof for a key." in
37
+
let man =
38
+
[
39
+
`S Manpage.s_description;
40
+
`P
41
+
"Verifies that a Merkle proof correctly proves a read operation. \
42
+
Returns exit code 0 if valid, 1 if invalid.";
43
+
`S Manpage.s_examples;
44
+
`Pre " irmin proof verify -k mykey foo=bar baz=qux";
45
+
]
46
+
in
47
+
Cmd.v
48
+
(Cmd.info "verify" ~doc ~man)
49
+
Term.(
50
+
const (fun () output key data -> ignore (run ~output ~key data))
51
+
$ Terms.setup $ Terms.output $ Cmd_proof_shared.proof_key
52
+
$ Cmd_proof_shared.proof_data)
+2
-2
bin/cmd_serve.ml
+2
-2
bin/cmd_serve.ml
···
593
593
| Some s -> Common.path_of_string s
594
594
| None -> []
595
595
596
-
let find_invalid_filename files =
596
+
let invalid_filename files =
597
597
List.find_map
598
598
(fun (fn, _) ->
599
599
match sanitize_filename fn with Ok _ -> None | Error m -> Some m)
···
629
629
let target_dir = target_dir_of_parts parts in
630
630
if files = [] then Respond.Response.bad_request "no file part in upload"
631
631
else
632
-
match find_invalid_filename files with
632
+
match invalid_filename files with
633
633
| Some m -> Respond.Response.bad_request m
634
634
| None ->
635
635
let root_c =
+1
test/dune
+1
test/dune
test/helpers.ml
test/helpers/helpers.ml
test/helpers.ml
test/helpers/helpers.ml
+2
test/helpers.mli
test/helpers/helpers.mli
+2
test/helpers.mli
test/helpers/helpers.mli