objective categorical abstract machine language personal data server
Optimize in-memory repo parsing
+90
-21
+80
mist/lib/mst.ml
+80
mist/lib/mst.ml
···
118
118
let%lwt result = Lazy.force lazy_opt_lwt in
119
119
f result
120
120
121
+
(* extracts leaves from a block map *)
122
+
let leaves_from_blocks (blocks : Block_map.t) (root : Cid.t) :
123
+
(string * Cid.t) list =
124
+
let leaves = ref [] in
125
+
let stack = Stack.create () in
126
+
Stack.push (root, "") stack ;
127
+
while not (Stack.is_empty stack) do
128
+
let cid, prefix = Stack.pop stack in
129
+
match Block_map.get cid blocks with
130
+
| None ->
131
+
() (* missing block probably a record *)
132
+
| Some bytes -> (
133
+
try
134
+
let node = decode_block_raw bytes in
135
+
(* proess left subtree *)
136
+
( match node.l with
137
+
| Some left_cid ->
138
+
Stack.push (left_cid, prefix) stack
139
+
| None ->
140
+
() ) ;
141
+
(* process entries in reverse order so they come out in correct order *)
142
+
let last_key = ref prefix in
143
+
List.iter
144
+
(fun (entry : entry_raw) ->
145
+
let key_prefix =
146
+
if entry.p = 0 then ""
147
+
else if entry.p <= String.length !last_key then
148
+
String.sub !last_key 0 entry.p
149
+
else !last_key
150
+
in
151
+
let full_key = key_prefix ^ Bytes.to_string entry.k in
152
+
last_key := full_key ;
153
+
leaves := (full_key, entry.v) :: !leaves ;
154
+
(* push right subtree to stack *)
155
+
match entry.t with
156
+
| Some right_cid ->
157
+
Stack.push (right_cid, full_key) stack
158
+
| None ->
159
+
() )
160
+
node.e
161
+
with Invalid_argument _ -> () )
162
+
done ;
163
+
List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) !leaves
164
+
165
+
(* extracts just mst node cids (non-leaf blocks) from a block map *)
166
+
let mst_node_cids_from_blocks (blocks : Block_map.t) (root : Cid.t) : Cid.t list
167
+
=
168
+
let nodes = ref [] in
169
+
let visited = ref Cid.Set.empty in
170
+
let stack = Stack.create () in
171
+
Stack.push root stack ;
172
+
while not (Stack.is_empty stack) do
173
+
let cid = Stack.pop stack in
174
+
if not (Cid.Set.mem cid !visited) then (
175
+
visited := Cid.Set.add cid !visited ;
176
+
match Block_map.get cid blocks with
177
+
| None ->
178
+
()
179
+
| Some bytes -> (
180
+
try
181
+
let node = decode_block_raw bytes in
182
+
nodes := cid :: !nodes ;
183
+
(* add all children to stack *)
184
+
( match node.l with
185
+
| Some left_cid ->
186
+
Stack.push left_cid stack
187
+
| None ->
188
+
() ) ;
189
+
List.iter
190
+
(fun (entry : entry_raw) ->
191
+
match entry.t with
192
+
| Some right_cid ->
193
+
Stack.push right_cid stack
194
+
| None ->
195
+
() )
196
+
node.e
197
+
with Invalid_argument _ -> () ) )
198
+
done ;
199
+
!nodes
200
+
121
201
module type Intf = sig
122
202
module Store : Writable_blockstore
123
203
+10
-21
pegasus/lib/repository.ml
+10
-21
pegasus/lib/repository.ml
···
592
592
failwith ("invalid commit: " ^ e)
593
593
in
594
594
if commit.did <> t.did then failwith "did does not match commit did" ;
595
-
(* create in-memory mst to walk *)
596
-
let mem_bs = Mist.Storage.Memory_blockstore.create ~blocks:all_blocks () in
597
-
let mem_mst : Mem_mst.t = {blockstore= mem_bs; root= commit.data} in
598
-
let%lwt leaves = Mem_mst.leaves_of_root mem_mst in
599
-
let leaf_cids =
600
-
List.fold_left
601
-
(fun acc (_, cid) -> Cid.Set.add cid acc)
602
-
Cid.Set.empty leaves
603
-
in
604
-
(* get mst nodes by filtering out leaves and commit from all blocks *)
595
+
let leaves = Mist.Mst.leaves_from_blocks all_blocks commit.data in
605
596
let mst_node_cids =
606
-
Block_map.keys all_blocks
607
-
|> List.filter (fun cid ->
608
-
(not (Cid.equal cid root)) && not (Cid.Set.mem cid leaf_cids) )
597
+
Mist.Mst.mst_node_cids_from_blocks all_blocks commit.data
609
598
in
610
599
(* collect mst node blocks for insert *)
611
600
let mst_blocks =
···
620
609
in
621
610
(* collect record data for insert *)
622
611
let since = Tid.now () in
623
-
let blob_refs : (string * Cid.t) list ref = ref [] in
624
-
let record_data =
625
-
List.map
626
-
(fun (path, cid) ->
612
+
let record_data, blob_refs =
613
+
List.fold_left
614
+
(fun (acc_data, acc_refs) (path, cid) ->
627
615
match Block_map.get cid all_blocks with
628
616
| Some data ->
629
617
let record = Lex.of_cbor data in
···
631
619
Util.find_blob_refs record
632
620
|> List.map (fun (br : Mist.Blob_ref.t) -> (path, br.ref))
633
621
in
634
-
blob_refs := record_refs @ !blob_refs ;
635
-
(path, cid, data, since)
622
+
( (path, cid, data, since) :: acc_data
623
+
, List.rev_append record_refs acc_refs )
636
624
| None ->
637
625
failwith ("missing record block: " ^ Cid.to_string cid) )
638
-
leaves
626
+
([], []) leaves
639
627
in
628
+
let record_data = List.rev record_data in
640
629
let%lwt _ =
641
630
Util.use_pool t.db.db (fun conn ->
642
631
Util.transact conn (fun () ->
···
645
634
let$! () = User_store.Bulk.put_blocks mst_blocks conn in
646
635
let$! () =
647
636
[%rapper execute {sql| DELETE FROM records |sql}] () conn
648
-
in
637
+
in
649
638
let$! () = User_store.Bulk.put_records record_data conn in
650
639
let$! () = User_store.Bulk.put_blob_refs !blob_refs conn in
651
640
Lwt.return_ok () ) )