objective categorical abstract machine language personal data server
MST path_to_entry + to_car_stream
+239
-37
+218
-33
mist/lib/mst.ml
+218
-33
mist/lib/mst.ml
···
3
3
type node_raw =
4
4
{ (* link to lower level left subtree with all keys sorting before this node *)
5
5
l: Cid.t option
6
-
; (* ordered list of entries below this node *)
6
+
; (* ordered list of entries in this node *)
7
7
e: entry_raw list }
8
8
9
9
and entry_raw =
···
38
38
and entry_hydrated =
39
39
{layer: int; key: string; value: Cid.t; right: node_hydrated option}
40
40
41
+
(* figures out where to put an entry in or below a hydrated node, returns new node *)
42
+
let rec insert_entry node entry : node_hydrated Lwt.t =
43
+
let entry_layer = Util.leading_zeros_on_hash entry.key in
44
+
(* as long as node layer <= entry layer, create a new node above node
45
+
until we have a node at the correct height for the entry to be inserted *)
46
+
let rec build_insert_node node layer =
47
+
if layer >= entry_layer then node
48
+
else
49
+
build_insert_node
50
+
{layer= layer + 1; left= Some node; entries= []}
51
+
(layer + 1)
52
+
in
53
+
let insert_node = build_insert_node node node.layer in
54
+
(* if entry is below node, recursively insert into node's left subtree *)
55
+
if entry_layer < insert_node.layer then
56
+
match (insert_node.entries, insert_node.left) with
57
+
| [], None ->
58
+
failwith "found totally empty mst node"
59
+
| [], Some left ->
60
+
node.left <- Some (Lwt_main.run (insert_entry left entry)) ;
61
+
Lwt.return insert_node
62
+
| _ ->
63
+
Lwt.return insert_node
64
+
else (
65
+
(* if entry is at this node's layer, append it to node's entries,
66
+
checking that its key occurs after the last existing entry *)
67
+
assert (node.layer = entry_layer) ;
68
+
( match Util.last node.entries with
69
+
| Some last ->
70
+
(* we can assert this because hydrate_from_map calls this function
71
+
while iterating over keys in sorted order *)
72
+
assert (entry.key > last.key)
73
+
| None ->
74
+
() ) ;
75
+
node.entries <- node.entries @ [entry] ;
76
+
Lwt.return node )
77
+
78
+
(* helper to find the entry with a given key in a hydrated node *)
79
+
let find_entry_nonrec node key =
80
+
let rec aux entries =
81
+
match entries with
82
+
| [] ->
83
+
None
84
+
| e :: es ->
85
+
if e.key = key then Some e else if e.key > key then None else aux es
86
+
in
87
+
aux node.entries
88
+
89
+
(* hydrates a list of entries with their keys; layer and right value are placeholders *)
90
+
let hydrate_entries_keys_only node =
91
+
node.e
92
+
|> List.fold_left
93
+
(fun (prev_path, entries) entry ->
94
+
let prefix = String.sub prev_path 0 entry.p in
95
+
let path = String.concat "" [prefix; Bytes.to_string entry.k] in
96
+
Util.ensure_valid_key path ;
97
+
(path, entries @ [{layer= 0; key= path; value= entry.v; right= None}]) )
98
+
("", [])
99
+
|> snd
100
+
41
101
module Make (Store : Storage.Writable_blockstore) = struct
42
102
type bs = Store.t
43
103
···
45
105
46
106
let create blockstore root = {blockstore; root}
47
107
108
+
(* decodes a node retrieved from the blockstore *)
48
109
let decode_block b : node_raw =
49
110
match Dag_cbor.decode b with
50
111
| `Map node ->
···
96
157
| _ ->
97
158
raise (Invalid_argument "invalid block")
98
159
160
+
(* retrieves & decodes a node by cid *)
99
161
let retrieve_node t cid : node_raw option Lwt.t =
100
162
match%lwt Store.get_bytes t.blockstore cid with
101
163
| Some bytes ->
···
103
165
| None ->
104
166
Lwt.return_none
105
167
168
+
(* returns the layer of a node *)
106
169
let rec get_node_height t node : int Lwt.t =
107
170
match (node.l, node.e) with
108
171
| None, [] ->
···
121
184
| _ ->
122
185
failwith "first node entry has nonzero p value" )
123
186
187
+
(* calls fn with each entry's key and cid *)
124
188
let traverse t fn : unit Lwt.t =
125
189
let rec traverse node =
126
190
let%lwt () =
···
149
213
| None ->
150
214
failwith "root cid not found in repo store"
151
215
216
+
(* returns a map of key -> cid *)
152
217
let build_map t : Cid.t StringMap.t Lwt.t =
153
218
let map = StringMap.empty in
154
219
let%lwt () =
···
156
221
in
157
222
Lwt.return map
158
223
159
-
let rec insert_entry node entry : node_hydrated Lwt.t =
160
-
let entry_layer = Util.leading_zeros_on_hash entry.key in
161
-
(* as long as node layer <= entry layer, create a new node above node
162
-
until we have a node at the correct height for the entry to be inserted *)
163
-
let rec build_insert_node node layer =
164
-
if layer >= entry_layer then node
165
-
else
166
-
build_insert_node
167
-
{layer= layer + 1; left= Some node; entries= []}
168
-
(layer + 1)
169
-
in
170
-
let insert_node = build_insert_node node node.layer in
171
-
(* if entry is below node, recursively insert into node's left subtree *)
172
-
if entry_layer < insert_node.layer then
173
-
match (insert_node.entries, insert_node.left) with
174
-
| [], None ->
175
-
failwith "found totally empty mst node"
176
-
| [], Some left ->
177
-
node.left <- Some (Lwt_main.run (insert_entry left entry)) ;
178
-
Lwt.return insert_node
179
-
| _ ->
180
-
Lwt.return insert_node
181
-
else (
182
-
(* if entry is at this node's layer, append it to node's entries,
183
-
checking that its key occurs after the last existing entry *)
184
-
assert (node.layer = entry_layer) ;
185
-
if List.length node.entries > 0 then
186
-
assert (entry.key > (List.rev node.entries |> List.hd).key) ;
187
-
node.entries <- node.entries @ [entry] ;
188
-
Lwt.return node )
189
-
190
-
let hydrate_from_map t map =
224
+
(* produces a hydrated mst from a map of key -> cid *)
225
+
let hydrate_from_map t map : Cid.t Lwt.t =
191
226
let keys =
192
227
map |> StringMap.bindings |> List.map fst |> List.sort String.compare
193
228
in
···
241
276
Lwt.return cid
242
277
in
243
278
finalize root
279
+
280
+
(* returns cids and blocks that form the path from a given node to a given entry *)
281
+
let rec path_to_entry t node key : (Cid.t * bytes) list Lwt.t =
282
+
let%lwt root_bytes = Store.get_bytes t node in
283
+
let%lwt root =
284
+
match root_bytes with
285
+
| None ->
286
+
Lwt.return_none
287
+
| Some bytes ->
288
+
Lwt.return_some (decode_block bytes)
289
+
in
290
+
let path_tail = [(node, Option.get root_bytes)] in
291
+
(* if there is a left child, try to find a path through the left subtree *)
292
+
let%lwt path_through_left =
293
+
match root with
294
+
| None ->
295
+
Lwt.return_some []
296
+
| Some root -> (
297
+
match root.l with
298
+
| None ->
299
+
Lwt.return_none
300
+
| Some left -> (
301
+
match%lwt path_to_entry t left key with
302
+
| [] ->
303
+
Lwt.return_none
304
+
| path ->
305
+
(* Option.get is safe because root is Some only when root_bytes is Some *)
306
+
Lwt.return_some (path @ path_tail) ) )
307
+
in
308
+
match path_through_left with
309
+
| Some path ->
310
+
Lwt.return path
311
+
| None -> (
312
+
(* if a left subtree path couldn't be found, find the entry whose right subtree this key would belong to *)
313
+
let root' = Option.get root in
314
+
let entries_keys = hydrate_entries_keys_only root' in
315
+
let entries_len = List.length root'.e in
316
+
let entry_index =
317
+
match List.find_index (fun e -> e.key >= key) entries_keys with
318
+
| Some index ->
319
+
index
320
+
| None ->
321
+
entries_len
322
+
in
323
+
(* entry_index here is actually the entry to the right of the subtree the key would belong to *)
324
+
match entry_index with
325
+
| _
326
+
(* because entries[entry_index] might turn out to be the entry we're looking for *)
327
+
when entry_index < entries_len
328
+
&& (List.nth entries_keys entry_index).key = key ->
329
+
Lwt.return path_tail
330
+
| _ -> (
331
+
(* otherwise, we continue down the right subtree of the entry before entry_index *)
332
+
match Util.last root'.e with
333
+
| Some last when last.t != None ->
334
+
let%lwt path_through_right =
335
+
path_to_entry t (Option.get last.t) key
336
+
in
337
+
Lwt.return (path_through_right @ path_tail)
338
+
| _ ->
339
+
Lwt.return path_tail ) )
340
+
341
+
(* returns all mst entries in order for a car stream *)
342
+
let to_car_stream t : (Cid.t * bytes) Seq.t =
343
+
let module M = struct
344
+
type stage =
345
+
| Nodes of
346
+
(* currently walking nodes *)
347
+
348
+
{ next: Cid.t list (* next cids to fetch *)
349
+
; fetched: (Cid.t * bytes) list (* fetched cids and their bytes *)
350
+
; leaves: Cid.Set.t (* seen leaf cids *) }
351
+
| Leaves of
352
+
(* done walking nodes, streaming accumulated leaves *)
353
+
(Cid.t * bytes) list
354
+
| Done
355
+
end in
356
+
let open M in
357
+
let init_state =
358
+
Nodes {next= [t.root]; fetched= []; leaves= Cid.Set.empty}
359
+
in
360
+
let rec step = function
361
+
| Done ->
362
+
None
363
+
(* node has been fetched, can now be yielded *)
364
+
| Nodes ({fetched= (cid, bytes) :: rest; _} as s) ->
365
+
Some ((cid, bytes), Nodes {s with fetched= rest})
366
+
(* need to fetch next nodes *)
367
+
| Nodes {next; fetched= []; leaves} ->
368
+
if List.is_empty next then (
369
+
(* finished traversing nodes, time to switch to leaves *)
370
+
let leaves_list = Cid.Set.to_list leaves in
371
+
let leaves_bm =
372
+
Lwt_main.run (Store.get_blocks t.blockstore leaves_list)
373
+
in
374
+
if leaves_bm.missing <> [] then failwith "missing mst leaf blocks" ;
375
+
let leaves_nodes = Storage.Block_map.entries leaves_bm.blocks in
376
+
match leaves_nodes with
377
+
| [] ->
378
+
(* with Done, we don't care about the first pair element *)
379
+
Some (Obj.magic (), Done)
380
+
| _ ->
381
+
(* it's leafin time *)
382
+
step (Leaves leaves_nodes) )
383
+
else
384
+
(* go ahead and fetch the next nodes *)
385
+
let bm = Lwt_main.run (Store.get_blocks t.blockstore next) in
386
+
if bm.missing <> [] then failwith "missing mst nodes" ;
387
+
let fetched, next', leaves' =
388
+
List.fold_left
389
+
(fun (acc, nxt, lvs) cid ->
390
+
let bytes =
391
+
(* we should be safe to do this since we just got the cids from the blockmap *)
392
+
Storage.Block_map.get cid bm.blocks |> Option.get
393
+
in
394
+
let node = decode_block bytes in
395
+
let nxt' =
396
+
List.fold_left
397
+
(* node.entries.map(e => e.right) *)
398
+
(fun n e -> match e.t with Some c -> c :: n | None -> n )
399
+
(* start with [node.left, ...nxt] if node has a left subtree *)
400
+
( match node.l with
401
+
| Some l ->
402
+
l :: nxt
403
+
| None ->
404
+
nxt )
405
+
node.e
406
+
in
407
+
let lvs' =
408
+
(* add each entry in this node to the list of seen leaves *)
409
+
List.fold_left (fun s e -> Cid.Set.add e.v s) lvs node.e
410
+
in
411
+
(* prepending is O(1) per prepend + one O(n) to reverse, vs. O(n) per append = O(n^2) total *)
412
+
((cid, bytes) :: acc, nxt', lvs') )
413
+
([], [], leaves) next
414
+
in
415
+
step
416
+
(Nodes
417
+
{ next= List.rev next'
418
+
; fetched= List.rev fetched
419
+
; leaves= leaves' } )
420
+
(* if we're onto yielding leaves, do that *)
421
+
| Leaves ((cid, bytes) :: rest) ->
422
+
let next = if rest = [] then Done else Leaves rest in
423
+
Some ((cid, bytes), next)
424
+
(* once we're out of leaves, we're done *)
425
+
| Leaves [] ->
426
+
Some (Obj.magic (), Done)
427
+
in
428
+
Seq.unfold step init_state
244
429
end
+7
mist/lib/storage/memory_store.ml
+7
mist/lib/storage/memory_store.ml
···
6
6
7
7
let create ?(blocks = Block_map.empty) () = {blocks; root= None; rev= None}
8
8
9
+
let get_root s =
10
+
match s.root with
11
+
| Some root ->
12
+
Lwt.return_some root
13
+
| None ->
14
+
Lwt.return_none
15
+
9
16
let get_bytes s cid = Lwt.return (Block_map.get cid s.blocks)
10
17
11
18
let has s cid = Lwt.return (Block_map.has cid s.blocks)
+9
-4
mist/lib/storage/overlay_store.ml
+9
-4
mist/lib/storage/overlay_store.ml
···
9
9
10
10
let create top bottom = {top; bottom}
11
11
12
+
let get_root {top; bottom} =
13
+
match%lwt Top.get_root top with
14
+
| Some _ as res ->
15
+
Lwt.return res
16
+
| None ->
17
+
Bottom.get_root bottom
18
+
12
19
let get_bytes {top; bottom} cid =
13
-
let* from_top = Top.get_bytes top cid in
14
-
match from_top with
20
+
match%lwt Top.get_bytes top cid with
15
21
| Some _ as res ->
16
22
Lwt.return res
17
23
| None ->
18
24
Bottom.get_bytes bottom cid
19
25
20
26
let has {top; bottom} cid =
21
-
let* from_top = Top.has top cid in
22
-
match from_top with
27
+
match%lwt Top.has top cid with
23
28
| true ->
24
29
Lwt.return_true
25
30
| false ->
+2
mist/lib/storage/repo_store.ml
+2
mist/lib/storage/repo_store.ml