8bit.lol
forked from
futur.blue/pegasus
objective categorical abstract machine language personal data server
Fix record non-inclusion in sync.getRecord
futur.blue
+92
-309
+6
mist/lib/lex.ml
+6
mist/lib/lex.ml
···
91
[@to_yojson fun v -> to_yojson (`LexMap v)] )
92
[@@deriving yojson]
93
94
+
let repo_record_to_string (record : repo_record) =
95
+
record |> repo_record_to_yojson |> Yojson.Safe.to_string
96
+
97
+
let repo_record_to_cbor_block (record : repo_record) =
98
+
to_cbor_block (`LexMap record)
99
+
100
let of_cbor encoded : repo_record =
101
let decoded = Dag_cbor.decode encoded in
102
match of_ipld decoded with
+40
-97
mist/lib/mst.ml
+40
-97
mist/lib/mst.ml
···
88
89
val proof_for_key : t -> Cid.t -> string -> Block_map.t Lwt.t
90
91
-
val get_covering_proof : t -> string -> Storage.Block_map.t Lwt.t
92
-
93
val leaf_count : t -> int Lwt.t
94
95
val layer : t -> int Lwt.t
···
496
let index = find_gte_leaf_index key seq in
497
let%lwt blocks =
498
match Util.at_index index seq with
499
-
| Some (Leaf (k, v, _)) when k = key -> (
500
-
(* include the found leaf block to prove existence *)
501
-
match%lwt
502
-
Store.get_bytes t.blockstore v
503
-
with
504
-
| Some leaf_bytes ->
505
-
Lwt.return (Block_map.set v leaf_bytes Block_map.empty)
506
-
| None ->
507
-
Lwt.return Block_map.empty )
508
-
| _ -> (
509
let prev =
510
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
511
in
···
553
Lwt.return bm )
554
in
555
Lwt.return (Block_map.set cid bytes blocks)
556
-
557
-
(* returns all mst nodes needed to prove the value of a given key's left sibling *)
558
-
let rec proof_for_left_sibling t cid key : Block_map.t Lwt.t =
559
-
match%lwt Store.get_bytes t.blockstore cid with
560
-
| None ->
561
-
Lwt.return Block_map.empty
562
-
| Some bytes ->
563
-
let raw = decode_block_raw bytes in
564
-
let keys = node_entry_keys raw in
565
-
let seq = interleave_raw raw keys in
566
-
let index = find_gte_leaf_index key seq in
567
-
let%lwt blocks =
568
-
let prev =
569
-
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
570
-
in
571
-
match prev with
572
-
| Some (Tree c) ->
573
-
proof_for_left_sibling t c key
574
-
| Some (Leaf (_, v_left, _)) -> (
575
-
match%lwt Store.get_bytes t.blockstore v_left with
576
-
| Some b ->
577
-
Lwt.return (Block_map.set v_left b Block_map.empty)
578
-
| None ->
579
-
Lwt.return Block_map.empty )
580
-
| _ ->
581
-
Lwt.return Block_map.empty
582
-
in
583
-
Lwt.return (Block_map.set cid bytes blocks)
584
-
585
-
(* returns all mst nodes needed to prove the value of a given key's right sibling *)
586
-
let rec proof_for_right_sibling t cid key : Block_map.t Lwt.t =
587
-
match%lwt Store.get_bytes t.blockstore cid with
588
-
| None ->
589
-
Lwt.return Block_map.empty
590
-
| Some bytes ->
591
-
let raw = decode_block_raw bytes in
592
-
let keys = node_entry_keys raw in
593
-
let seq = interleave_raw raw keys in
594
-
let index = find_gte_leaf_index key seq in
595
-
let found =
596
-
match Util.at_index index seq with
597
-
| None ->
598
-
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
599
-
| some ->
600
-
some
601
-
in
602
-
let%lwt blocks =
603
-
match found with
604
-
| Some (Tree c) ->
605
-
proof_for_right_sibling t c key
606
-
| Some (Leaf (k, _, _)) -> (
607
-
let neighbor =
608
-
if k = key then Util.at_index (index + 1) seq
609
-
else if index - 1 >= 0 then Util.at_index (index - 1) seq
610
-
else None
611
-
in
612
-
match neighbor with
613
-
| Some (Tree c) ->
614
-
proof_for_right_sibling t c key
615
-
| Some (Leaf (_, v_right, _)) -> (
616
-
match%lwt Store.get_bytes t.blockstore v_right with
617
-
| Some b ->
618
-
Lwt.return (Block_map.set v_right b Block_map.empty)
619
-
| None ->
620
-
Lwt.return Block_map.empty )
621
-
| _ ->
622
-
Lwt.return Block_map.empty )
623
-
| None ->
624
-
Lwt.return Block_map.empty
625
-
in
626
-
Lwt.return (Block_map.set cid bytes blocks)
627
-
628
-
(* a covering proof is all mst nodes needed to prove the value of a given leaf
629
-
and its siblings to its immediate right and left (if applicable) *)
630
-
let get_covering_proof t key : Block_map.t Lwt.t =
631
-
let%lwt proofs =
632
-
Lwt.all
633
-
[ proof_for_key t t.root key
634
-
; proof_for_left_sibling t t.root key
635
-
; proof_for_right_sibling t t.root key ]
636
-
in
637
-
Lwt.return
638
-
(List.fold_left
639
-
(fun acc proof -> Block_map.merge acc proof)
640
-
Block_map.empty proofs )
641
642
(* collects all node blocks (cid, bytes) and all leaf cids reachable from root
643
only traverses nodes; doesn't fetch leaf blocks
···
88
89
val proof_for_key : t -> Cid.t -> string -> Block_map.t Lwt.t
90
91
val leaf_count : t -> int Lwt.t
92
93
val layer : t -> int Lwt.t
···
494
let index = find_gte_leaf_index key seq in
495
let%lwt blocks =
496
match Util.at_index index seq with
497
+
| Some (Leaf (k, _, _)) when k = key ->
498
+
Lwt.return Block_map.empty
499
+
| Some (Leaf (k, v_right, _)) -> (
500
+
let prev =
501
+
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
502
+
in
503
+
match prev with
504
+
| Some (Tree c) ->
505
+
proof_for_key t c key
506
+
| _ ->
507
+
(* include bounding neighbor leaf blocks to prove nonexistence *)
508
+
let left_leaf =
509
+
match prev with
510
+
| Some (Leaf (_, v_left, _)) ->
511
+
Some v_left
512
+
| _ ->
513
+
None
514
+
in
515
+
let%lwt bm =
516
+
match left_leaf with
517
+
| Some cid_left -> (
518
+
match%lwt Store.get_bytes t.blockstore cid_left with
519
+
| Some b ->
520
+
Lwt.return (Block_map.set cid_left b Block_map.empty)
521
+
| None ->
522
+
Lwt.return Block_map.empty )
523
+
| None ->
524
+
Lwt.return Block_map.empty
525
+
in
526
+
let%lwt bm =
527
+
match%lwt Store.get_bytes t.blockstore v_right with
528
+
| Some b ->
529
+
Lwt.return (Block_map.set v_right b bm)
530
+
| None ->
531
+
Lwt.return bm
532
+
in
533
+
Lwt.return bm )
534
+
| Some (Tree c) ->
535
+
proof_for_key t c key
536
+
| None -> (
537
let prev =
538
if index - 1 >= 0 then Util.at_index (index - 1) seq else None
539
in
···
581
Lwt.return bm )
582
in
583
Lwt.return (Block_map.set cid bytes blocks)
584
585
(* collects all node blocks (cid, bytes) and all leaf cids reachable from root
586
only traverses nodes; doesn't fetch leaf blocks
-183
mist/test/test_mst.ml
-183
mist/test/test_mst.ml
···
8
let cid_of_string_exn s =
9
match Cid.of_string s with Ok c -> c | Error msg -> failwith msg
10
11
-
module Keys = struct
12
-
let a0 = "A0/501344"
13
-
14
-
let a2 = "A2/239654"
15
-
16
-
let b0 = "B0/436099"
17
-
18
-
let b1 = "B1/293486"
19
-
20
-
let b2 = "B2/303249"
21
-
22
-
let c0 = "C0/535043"
23
-
24
-
let c2 = "C2/953910"
25
-
26
-
let d0 = "D0/360671"
27
-
28
-
let d2 = "D2/915466"
29
-
30
-
let e0 = "E0/922708"
31
-
32
-
let e2 = "E2/413113"
33
-
34
-
let f0 = "F0/606463"
35
-
36
-
let f1 = "F1/415452"
37
-
38
-
let g0 = "G0/714257"
39
-
40
-
let g2 = "G2/536869"
41
-
42
-
let h0 = "H0/740256"
43
-
end
44
-
45
-
let leaf_cid =
46
-
cid_of_string_exn
47
-
"bafyreie5cvv4h45feadgeuwhbcutmh6t2ceseocckahdoe6uat64zmz454"
48
-
49
-
let mst_of_proof root proof : Mem_mst.t =
50
-
let store = Storage.Memory_blockstore.create ~blocks:proof () in
51
-
Mem_mst.create store root
52
-
53
-
let test_two_deep_split () =
54
-
let store = Storage.Memory_blockstore.create () in
55
-
let* mst = Mem_mst.create_empty store in
56
-
let%lwt mst = Mem_mst.add mst Keys.a0 leaf_cid in
57
-
let%lwt mst = Mem_mst.add mst Keys.b1 leaf_cid in
58
-
let%lwt mst = Mem_mst.add mst Keys.c0 leaf_cid in
59
-
let%lwt mst = Mem_mst.add mst Keys.e0 leaf_cid in
60
-
let%lwt mst = Mem_mst.add mst Keys.f1 leaf_cid in
61
-
let%lwt mst = Mem_mst.add mst Keys.g0 leaf_cid in
62
-
let%lwt mst = Mem_mst.add mst Keys.d2 leaf_cid in
63
-
let%lwt proof = Mem_mst.get_covering_proof mst Keys.d2 in
64
-
let proof_mst = mst_of_proof mst.root proof in
65
-
let%lwt got = Mem_mst.get_cid proof_mst Keys.d2 in
66
-
Alcotest.(check bool)
67
-
"covering proof proves d2" true
68
-
(Option.value
69
-
(Option.map (fun x -> Cid.equal leaf_cid x) got)
70
-
~default:false ) ;
71
-
Lwt.return_ok ()
72
-
73
-
let test_two_deep_leafless_splits () =
74
-
let store = Storage.Memory_blockstore.create () in
75
-
let* mst = Mem_mst.create_empty store in
76
-
let%lwt mst = Mem_mst.add mst Keys.a0 leaf_cid in
77
-
let%lwt mst = Mem_mst.add mst Keys.b0 leaf_cid in
78
-
let%lwt mst = Mem_mst.add mst Keys.d0 leaf_cid in
79
-
let%lwt mst = Mem_mst.add mst Keys.e0 leaf_cid in
80
-
let%lwt mst = Mem_mst.add mst Keys.c2 leaf_cid in
81
-
let%lwt proof = Mem_mst.get_covering_proof mst Keys.c2 in
82
-
let proof_mst = mst_of_proof mst.root proof in
83
-
let%lwt got = Mem_mst.get_cid proof_mst Keys.c2 in
84
-
Alcotest.(check bool)
85
-
"covering proof proves c2" true
86
-
(Option.value
87
-
(Option.map (fun x -> Cid.equal leaf_cid x) got)
88
-
~default:false ) ;
89
-
Lwt.return_ok ()
90
-
91
-
let test_add_on_edge_with_neighbor_two_layers_down () =
92
-
let store = Storage.Memory_blockstore.create () in
93
-
let* mst = Mem_mst.create_empty store in
94
-
let%lwt mst = Mem_mst.add mst Keys.a0 leaf_cid in
95
-
let%lwt mst = Mem_mst.add mst Keys.b2 leaf_cid in
96
-
let%lwt mst = Mem_mst.add mst Keys.c0 leaf_cid in
97
-
let%lwt mst = Mem_mst.add mst Keys.d2 leaf_cid in
98
-
let%lwt proof = Mem_mst.get_covering_proof mst Keys.d2 in
99
-
let proof_mst = mst_of_proof mst.root proof in
100
-
let%lwt got = Mem_mst.get_cid proof_mst Keys.d2 in
101
-
Alcotest.(check bool)
102
-
"covering proof proves d2" true
103
-
(Option.value
104
-
(Option.map (fun x -> Cid.equal leaf_cid x) got)
105
-
~default:false ) ;
106
-
Lwt.return_ok ()
107
-
108
-
let test_merge_and_split_in_multi_op_commit () =
109
-
let store = Storage.Memory_blockstore.create () in
110
-
let* mst = Mem_mst.create_empty store in
111
-
let%lwt mst = Mem_mst.add mst Keys.b0 leaf_cid in
112
-
let%lwt mst = Mem_mst.add mst Keys.c2 leaf_cid in
113
-
let%lwt mst = Mem_mst.add mst Keys.d0 leaf_cid in
114
-
let%lwt mst = Mem_mst.add mst Keys.e2 leaf_cid in
115
-
let%lwt mst = Mem_mst.add mst Keys.f0 leaf_cid in
116
-
let%lwt mst = Mem_mst.add mst Keys.h0 leaf_cid in
117
-
let%lwt mst = Mem_mst.delete mst Keys.b2 in
118
-
let%lwt mst = Mem_mst.delete mst Keys.d2 in
119
-
let%lwt mst = Mem_mst.add mst Keys.c2 leaf_cid in
120
-
let%lwt proofs =
121
-
Lwt.all
122
-
[ Mem_mst.get_covering_proof mst Keys.b2
123
-
; Mem_mst.get_covering_proof mst Keys.d2
124
-
; Mem_mst.get_covering_proof mst Keys.c2 ]
125
-
in
126
-
let proof =
127
-
List.fold_left Storage.Block_map.merge Storage.Block_map.empty proofs
128
-
in
129
-
let proof_mst = mst_of_proof mst.root proof in
130
-
let%lwt got_c2 = Mem_mst.get_cid proof_mst Keys.c2 in
131
-
Alcotest.(check bool)
132
-
"covering proof proves c2" true
133
-
(Option.value
134
-
(Option.map (fun x -> Cid.equal leaf_cid x) got_c2)
135
-
~default:false ) ;
136
-
let%lwt got_b2 = Mem_mst.get_cid proof_mst Keys.b2 in
137
-
Alcotest.(check bool)
138
-
"covering proof proves non-membership of b2" true (got_b2 = None) ;
139
-
let%lwt got_d2 = Mem_mst.get_cid proof_mst Keys.d2 in
140
-
Alcotest.(check bool)
141
-
"covering proof proves non-membership of d2" true (got_d2 = None) ;
142
-
Lwt.return_ok ()
143
-
144
-
let test_complex_multi_op_commit () =
145
-
let store = Storage.Memory_blockstore.create () in
146
-
let* mst = Mem_mst.create_empty store in
147
-
let%lwt mst = Mem_mst.add mst Keys.b0 leaf_cid in
148
-
let%lwt mst = Mem_mst.add mst Keys.c2 leaf_cid in
149
-
let%lwt mst = Mem_mst.add mst Keys.d0 leaf_cid in
150
-
let%lwt mst = Mem_mst.add mst Keys.e2 leaf_cid in
151
-
let%lwt mst = Mem_mst.add mst Keys.f0 leaf_cid in
152
-
let%lwt mst = Mem_mst.add mst Keys.h0 leaf_cid in
153
-
let%lwt mst = Mem_mst.add mst Keys.a2 leaf_cid in
154
-
let%lwt mst = Mem_mst.add mst Keys.g2 leaf_cid in
155
-
let%lwt mst = Mem_mst.delete mst Keys.c2 in
156
-
let%lwt proofs =
157
-
Lwt.all
158
-
[ Mem_mst.get_covering_proof mst Keys.a2
159
-
; Mem_mst.get_covering_proof mst Keys.g2
160
-
; Mem_mst.get_covering_proof mst Keys.c2 ]
161
-
in
162
-
let proof =
163
-
List.fold_left Storage.Block_map.merge Storage.Block_map.empty proofs
164
-
in
165
-
let proof_mst = mst_of_proof mst.root proof in
166
-
let%lwt got_a2 = Mem_mst.get_cid proof_mst Keys.a2 in
167
-
Alcotest.(check bool)
168
-
"covering proof proves a2" true
169
-
(Option.value
170
-
(Option.map (fun x -> Cid.equal leaf_cid x) got_a2)
171
-
~default:false ) ;
172
-
let%lwt got_g2 = Mem_mst.get_cid proof_mst Keys.g2 in
173
-
Alcotest.(check bool)
174
-
"covering proof proves g2" true
175
-
(Option.value
176
-
(Option.map (fun x -> Cid.equal leaf_cid x) got_g2)
177
-
~default:false ) ;
178
-
let%lwt got_c2 = Mem_mst.get_cid proof_mst Keys.c2 in
179
-
Alcotest.(check bool)
180
-
"covering proof proves non-membership of c2" true (got_c2 = None) ;
181
-
Lwt.return_ok ()
182
-
183
let test_trims_top_on_delete () =
184
let store = Storage.Memory_blockstore.create () in
185
let cid1 =
···
893
, [ test_case "allowed mst keys" `Quick (fun () ->
894
run_test test_allowable_keys ) ] )
895
; ("diffs", [test_case "diffs" `Quick (fun () -> run_test test_diffs)])
896
-
; ( "covering-proofs"
897
-
, [ test_case "two deep split" `Quick (fun () ->
898
-
run_test test_two_deep_split )
899
-
; test_case "two deep leafless splits" `Quick (fun () ->
900
-
run_test test_two_deep_leafless_splits )
901
-
; test_case "edge with neighbour two layers down" `Quick (fun () ->
902
-
run_test test_add_on_edge_with_neighbor_two_layers_down )
903
-
; test_case "merge and split in multi-op commit" `Quick (fun () ->
904
-
run_test test_merge_and_split_in_multi_op_commit )
905
-
; test_case "complex multi-op commit" `Quick (fun () ->
906
-
run_test test_complex_multi_op_commit ) ] )
907
; ( "interop edge cases"
908
, [ test_case "trims top of tree on delete" `Quick (fun () ->
909
run_test test_trims_top_on_delete )
···
8
let cid_of_string_exn s =
9
match Cid.of_string s with Ok c -> c | Error msg -> failwith msg
10
11
let test_trims_top_on_delete () =
12
let store = Storage.Memory_blockstore.create () in
13
let cid1 =
···
721
, [ test_case "allowed mst keys" `Quick (fun () ->
722
run_test test_allowable_keys ) ] )
723
; ("diffs", [test_case "diffs" `Quick (fun () -> run_test test_diffs)])
724
; ( "interop edge cases"
725
, [ test_case "trims top of tree on delete" `Quick (fun () ->
726
run_test test_trims_top_on_delete )
+34
-23
pegasus/lib/api/sync/getRecord.ml
+34
-23
pegasus/lib/api/sync/getRecord.ml
···
9
Xrpc.parse_query ctx.req query_of_yojson
10
in
11
let path = collection ^ "/" ^ rkey in
12
-
let%lwt {db; commit; _} =
13
Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
14
in
15
-
let commit_cid, commit_signed = Option.get commit in
16
-
let commit_block =
17
-
commit_signed |> User_store.Types.signed_commit_to_yojson
18
-
|> Dag_cbor.encode_yojson
19
-
in
20
-
let mst_root = commit_signed.data in
21
-
let%lwt blocks =
22
-
Mst.proof_for_key {blockstore= db; root= mst_root} mst_root path
23
-
in
24
-
let blocks_stream =
25
-
Repository.Block_map.entries blocks |> Lwt_seq.of_list
26
-
in
27
-
let car_stream =
28
-
Lwt_seq.cons (commit_cid, commit_block) blocks_stream
29
-
|> Car.blocks_to_stream commit_cid
30
-
in
31
-
Dream.stream
32
-
~headers:[("Content-Type", "application/vnd.ipld.car")]
33
-
(fun res_stream ->
34
-
Lwt_seq.iter_s
35
-
(fun chunk -> Dream.write res_stream (Bytes.to_string chunk))
36
-
car_stream ) )
···
9
Xrpc.parse_query ctx.req query_of_yojson
10
in
11
let path = collection ^ "/" ^ rkey in
12
+
let%lwt repo =
13
Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
14
in
15
+
match%lwt Repository.get_record repo path with
16
+
| None ->
17
+
Printf.ksprintf
18
+
(Errors.not_found ?name:None)
19
+
"record %s not found"
20
+
("at://" ^ did ^ "/" ^ path)
21
+
| Some record ->
22
+
let record_block = Mist.Lex.repo_record_to_cbor_block record.value in
23
+
let commit_cid, commit_signed = Option.get repo.commit in
24
+
let commit_block =
25
+
commit_signed |> User_store.Types.signed_commit_to_yojson
26
+
|> Dag_cbor.encode_yojson
27
+
in
28
+
let mst_root = commit_signed.data in
29
+
let%lwt blocks =
30
+
Mst.proof_for_key
31
+
{blockstore= repo.db; root= mst_root}
32
+
mst_root path
33
+
in
34
+
let blocks_stream =
35
+
Repository.Block_map.entries blocks |> Lwt_seq.of_list
36
+
in
37
+
let car_stream =
38
+
Lwt_seq.cons (commit_cid, commit_block)
39
+
@@ Lwt_seq.cons record_block blocks_stream
40
+
|> Car.blocks_to_stream commit_cid
41
+
in
42
+
Dream.stream
43
+
~headers:[("Content-Type", "application/vnd.ipld.car")]
44
+
(fun res_stream ->
45
+
Lwt_seq.iter_s
46
+
(fun chunk -> Dream.write res_stream (Bytes.to_string chunk))
47
+
car_stream ) )
+1
-4
pegasus/lib/api/well_known.ml
+1
-4
pegasus/lib/api/well_known.ml
+11
-2
pegasus/lib/errors.ml
+11
-2
pegasus/lib/errors.ml
···
4
5
exception AuthError of (string * string)
6
7
exception UseDpopNonceError
8
9
let is_xrpc_error = function
10
-
| InvalidRequestError _ | InternalServerError _ | AuthError _ ->
11
true
12
| _ ->
13
false
···
16
raise (InvalidRequestError (name, msg))
17
18
let internal_error ?(name = "InternalServerError")
19
-
?(msg = "Internal server error") () =
20
raise (InternalServerError (name, msg))
21
22
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
23
24
let use_dpop_nonce () = raise UseDpopNonceError
25
···
35
format_response error message `Internal_Server_Error
36
| AuthError (error, message) ->
37
format_response error message `Unauthorized
38
| UseDpopNonceError ->
39
Dream.json ~status:`Bad_Request
40
~headers:
···
4
5
exception AuthError of (string * string)
6
7
+
exception NotFoundError of (string * string)
8
+
9
exception UseDpopNonceError
10
11
let is_xrpc_error = function
12
+
| InvalidRequestError _
13
+
| InternalServerError _
14
+
| AuthError _
15
+
| NotFoundError _ ->
16
true
17
| _ ->
18
false
···
21
raise (InvalidRequestError (name, msg))
22
23
let internal_error ?(name = "InternalServerError")
24
+
?(msg = "internal server error") () =
25
raise (InternalServerError (name, msg))
26
27
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
28
+
29
+
let not_found ?(name = "NotFound") msg = raise (NotFoundError (name, msg))
30
31
let use_dpop_nonce () = raise UseDpopNonceError
32
···
42
format_response error message `Internal_Server_Error
43
| AuthError (error, message) ->
44
format_response error message `Unauthorized
45
+
| NotFoundError (error, message) ->
46
+
format_response error message `Not_Found
47
| UseDpopNonceError ->
48
Dream.json ~status:`Bad_Request
49
~headers: