objective categorical abstract machine language personal data server
Use records table & layer hints to avoid unneeded mst traversal
+68
-64
+41
-35
mist/lib/mst.ml
+41
-35
mist/lib/mst.ml
···
207
207
208
208
val retrieve_node_raw : t -> Cid.t -> node_raw option Lwt.t
209
209
210
-
val retrieve_node : t -> Cid.t -> node option Lwt.t
210
+
val retrieve_node : ?layer_hint:int -> t -> Cid.t -> node option Lwt.t
211
211
212
-
val retrieve_node_lazy : t -> Cid.t -> node option Lwt.t lazy_t
212
+
val retrieve_node_lazy :
213
+
layer_hint:int -> t -> Cid.t -> node option Lwt.t lazy_t
213
214
214
-
val get_node_height : t -> node_raw -> int Lwt.t
215
+
val get_node_height : ?layer_hint:int -> t -> node_raw -> int Lwt.t
215
216
216
217
val traverse : t -> (string -> Cid.t -> unit) -> unit Lwt.t
217
218
···
271
272
| None ->
272
273
Lwt.return_none
273
274
274
-
(* retrieves & hydrates a node by cid *)
275
-
let rec retrieve_node t cid : node option Lwt.t =
276
-
match%lwt retrieve_node_raw t cid with
277
-
| Some raw ->
278
-
hydrate_node t raw |> Lwt.map Option.some
279
-
| None ->
280
-
Lwt.return_none
281
-
282
-
(* lazy version of retrieve_node *)
283
-
and retrieve_node_lazy t cid = lazy (retrieve_node t cid)
275
+
(* returns the layer of a node, using hint if provided *)
276
+
let rec get_node_height ?layer_hint t node : int Lwt.t =
277
+
match layer_hint with
278
+
| Some layer ->
279
+
Lwt.return layer
280
+
| None -> (
281
+
match (node.l, node.e) with
282
+
| None, [] ->
283
+
Lwt.return 0
284
+
| Some left, [] -> (
285
+
match%lwt retrieve_node_raw t left with
286
+
| Some node ->
287
+
let%lwt height = get_node_height t node in
288
+
Lwt.return (height + 1)
289
+
| None ->
290
+
failwith ("couldn't find node " ^ Cid.to_string left) )
291
+
| _, leaf :: _ -> (
292
+
match leaf.p with
293
+
| 0 ->
294
+
Lwt.return (Util.leading_zeros_on_hash (Bytes.to_string leaf.k))
295
+
| _ ->
296
+
failwith "first node entry has nonzero p value" ) )
284
297
285
298
(* hydrates a raw node *)
286
-
and hydrate_node t node_raw : node Lwt.t =
299
+
let rec hydrate_node ?layer_hint t node_raw : node Lwt.t =
300
+
let%lwt layer = get_node_height ?layer_hint t node_raw in
301
+
let child_layer = layer - 1 in
287
302
let left =
288
303
match node_raw.l with
289
304
| Some l ->
290
-
retrieve_node_lazy t l
305
+
retrieve_node_lazy ~layer_hint:child_layer t l
291
306
| None ->
292
307
lazy Lwt.return_none
293
308
in
294
-
let%lwt layer = get_node_height t node_raw in
295
309
let entries =
296
310
List.fold_left
297
311
(fun (entries : entry list) entry ->
···
307
321
let right =
308
322
match entry.t with
309
323
| Some r ->
310
-
retrieve_node_lazy t r
324
+
retrieve_node_lazy ~layer_hint:child_layer t r
311
325
| None ->
312
326
lazy Lwt.return_none
313
327
in
···
316
330
in
317
331
Lwt.return {layer; left; entries}
318
332
319
-
(* returns the layer of a node *)
320
-
and get_node_height t node : int Lwt.t =
321
-
match (node.l, node.e) with
322
-
| None, [] ->
323
-
Lwt.return 0
324
-
| Some left, [] -> (
325
-
match%lwt retrieve_node_raw t left with
326
-
| Some node ->
327
-
let%lwt height = get_node_height t node in
328
-
Lwt.return (height + 1)
329
-
| None ->
330
-
failwith ("couldn't find node " ^ Cid.to_string left) )
331
-
| _, leaf :: _ -> (
332
-
match leaf.p with
333
-
| 0 ->
334
-
Lwt.return (Util.leading_zeros_on_hash (Bytes.to_string leaf.k))
335
-
| _ ->
336
-
failwith "first node entry has nonzero p value" )
333
+
(* retrieves & hydrates a node by cid *)
334
+
and retrieve_node ?layer_hint t cid : node option Lwt.t =
335
+
match%lwt retrieve_node_raw t cid with
336
+
| Some raw ->
337
+
hydrate_node ?layer_hint t raw |> Lwt.map Option.some
338
+
| None ->
339
+
Lwt.return_none
340
+
341
+
and retrieve_node_lazy ~layer_hint t cid =
342
+
lazy (retrieve_node ~layer_hint t cid)
337
343
338
344
(* calls fn with each entry's key and cid *)
339
345
let traverse t fn : unit Lwt.t =
+12
-29
pegasus/lib/repository.ml
+12
-29
pegasus/lib/repository.ml
···
263
263
: write_result Lwt.t =
264
264
with_write_lock t.did (fun () ->
265
265
let open Sequencer.Types in
266
-
let module Inductive = Mist.Mst.Inductive (Mst) in
267
266
let%lwt prev_commit =
268
267
match%lwt User_store.get_commit t.db with
269
268
| Some (_, commit) ->
···
280
279
Cid.to_string c
281
280
| None ->
282
281
"null" ) ) ;
283
-
let%lwt block_map = Lwt.map ref (get_map t) in
284
282
let cached_store = Cached_store.create t.db in
285
283
let mst : Cached_mst.t ref =
286
284
ref (Cached_mst.create cached_store prev_commit.data)
287
285
in
286
+
t.block_map <- None ;
288
287
(* ops to emit, built in loop because prev_data (previous cid) is otherwise inaccessible *)
289
288
let commit_ops : commit_evt_op list ref = ref [] in
290
289
let added_leaves = ref Block_map.empty in
···
297
296
let path = Format.sprintf "%s/%s" collection rkey in
298
297
let uri = Format.sprintf "at://%s/%s" t.did path in
299
298
let%lwt () =
300
-
match String_map.find_opt path !block_map with
299
+
match%lwt User_store.get_record_cid t.db path with
301
300
| Some cid ->
302
301
Errors.invalid_request ~name:"InvalidSwap"
303
302
(Format.sprintf
···
314
313
let%lwt cid, block =
315
314
User_store.put_record t.db (`LexMap record_with_type) path
316
315
in
317
-
block_map := String_map.add path cid !block_map ;
318
316
added_leaves := Block_map.set cid block !added_leaves ;
319
317
commit_ops :=
320
318
!commit_ops
···
340
338
| Update {collection; rkey; value; swap_record; _} ->
341
339
let path = Format.sprintf "%s/%s" collection rkey in
342
340
let uri = Format.sprintf "at://%s/%s" t.did path in
343
-
let old_cid = String_map.find_opt path !block_map in
341
+
let%lwt old_cid = User_store.get_record_cid t.db path in
344
342
( if
345
343
(swap_record <> None && swap_record <> old_cid)
346
344
|| (swap_record = None && old_cid = None)
···
385
383
User_store.put_record t.db (`LexMap record_with_type) path
386
384
in
387
385
added_leaves := Block_map.set new_cid new_block !added_leaves ;
388
-
block_map := String_map.add path new_cid !block_map ;
389
386
commit_ops :=
390
387
!commit_ops
391
388
@ [{action= `Update; path; cid= Some new_cid; prev= old_cid}] ;
···
409
406
; cid= new_cid } )
410
407
| Delete {collection; rkey; swap_record; _} ->
411
408
let path = Format.sprintf "%s/%s" collection rkey in
412
-
let cid = String_map.find_opt path !block_map in
409
+
let%lwt cid = User_store.get_record_cid t.db path in
413
410
( if cid = None || (swap_record <> None && swap_record <> cid)
414
411
then
415
412
let cid_str =
···
441
438
Lwt.return_unit
442
439
in
443
440
let%lwt () = User_store.delete_record t.db path in
444
-
block_map := String_map.remove path !block_map ;
445
441
commit_ops :=
446
442
!commit_ops @ [{action= `Delete; path; cid= None; prev= cid}] ;
447
443
let%lwt new_mst = Cached_mst.delete !mst path in
···
458
454
let commit_block =
459
455
new_commit_signed |> signed_commit_to_yojson |> Dag_cbor.encode_yojson
460
456
in
461
-
let diff : Inductive.diff list =
462
-
List.fold_left
463
-
(fun (acc : Inductive.diff list)
464
-
({action; path; cid; prev} : commit_evt_op) ->
465
-
match action with
466
-
| `Create ->
467
-
acc @ [Add {key= path; cid= Option.get cid}]
468
-
| `Update ->
469
-
acc @ [Update {key= path; cid= Option.get cid; prev}]
470
-
| `Delete ->
471
-
acc @ [Delete {key= path; prev= Option.get prev}] )
472
-
[] !commit_ops
473
-
in
474
457
let%lwt proof_blocks =
475
-
match%lwt
476
-
Inductive.generate_proof !block_map diff ~new_root:new_mst.root
477
-
~prev_root:prev_commit.data
478
-
with
479
-
| Ok blocks ->
480
-
Lwt.return (Block_map.merge blocks !added_leaves)
481
-
| Error err ->
482
-
raise err
458
+
Lwt_list.fold_left_s
459
+
(fun acc ({path; _} : commit_evt_op) ->
460
+
let%lwt key_proof =
461
+
Cached_mst.proof_for_key new_mst new_mst.root path
462
+
in
463
+
Lwt.return (Block_map.merge acc key_proof) )
464
+
Block_map.empty !commit_ops
483
465
in
466
+
let proof_blocks = Block_map.merge proof_blocks !added_leaves in
484
467
let block_stream =
485
468
proof_blocks |> Block_map.entries |> Lwt_seq.of_list
486
469
|> Lwt_seq.cons (new_commit_cid, commit_block)
+15
pegasus/lib/user_store.ml
+15
pegasus/lib/user_store.ml
···
129
129
~cid ~data
130
130
131
131
(* record storage *)
132
+
let get_record_cid =
133
+
[%rapper
134
+
get_opt
135
+
{sql| SELECT @CID{cid} FROM records WHERE path = %string{path} |sql}]
136
+
137
+
let get_all_record_cids =
138
+
[%rapper get_many {sql| SELECT @string{path}, @CID{cid} FROM records |sql}]
139
+
()
140
+
132
141
let get_record =
133
142
[%rapper
134
143
get_opt
···
390
399
Util.use_pool t.db @@ Queries.get_record ~path
391
400
>|= Option.map (fun (cid, data, since) ->
392
401
{path; cid; value= Lex.of_cbor data; since} )
402
+
403
+
let get_record_cid t path : Cid.t option Lwt.t =
404
+
Util.use_pool t.db @@ Queries.get_record_cid ~path
405
+
406
+
let get_all_record_cids t : (string * Cid.t) list Lwt.t =
407
+
Util.use_pool t.db Queries.get_all_record_cids
393
408
394
409
let get_records_by_cids t cids : (Cid.t * Blob.t) list Lwt.t =
395
410
if List.is_empty cids then Lwt.return []