objective categorical abstract machine language personal data server
Fix incorrect inductive proof generation
+86
-26
+1
-2
mist/lib/lex.ml
+1
-2
mist/lib/lex.ml
···
48
48
match v with
49
49
| `Map m ->
50
50
if
51
-
StringMap.mem "$type" m
51
+
(StringMap.mem "$type" m && StringMap.find "$type" m = `String "blob")
52
52
|| (StringMap.mem "cid" m && StringMap.mem "mimeType" m)
53
-
|| (StringMap.mem "size" m && StringMap.mem "mimeType" m)
54
53
then `BlobRef (Blob_ref.of_ipld (`Map m))
55
54
else `LexMap (StringMap.map of_ipld m)
56
55
| `Array a ->
+28
-22
mist/lib/mst.ml
+28
-22
mist/lib/mst.ml
···
259
259
let*? left = node.left in
260
260
match left with Some l -> traverse l | None -> Lwt.return_unit
261
261
in
262
-
List.iter (fun (entry : entry) -> fn entry.key entry.value) node.entries ;
262
+
let%lwt () =
263
+
Lwt_list.iter_s
264
+
(fun (entry : entry) ->
265
+
fn entry.key entry.value ;
266
+
let*? right = entry.right in
267
+
match right with Some r -> traverse r | None -> Lwt.return_unit )
268
+
node.entries
269
+
in
263
270
Lwt.return_unit
264
271
in
265
272
match%lwt retrieve_node t t.root with
···
935
942
in
936
943
persist_from_sorted sorted >|= fun (root, _) -> {blockstore; root}
937
944
938
-
(* insert or replace an entry, returning a new canonical mst
939
-
doesn't persist changes *)
945
+
(* insert or replace an entry, returning a new canonical mst *)
940
946
let add t key cid : t Lwt.t =
941
947
Util.ensure_valid_key key ;
942
948
let%lwt leaves = leaves_of_root t in
943
949
let without = List.filter (fun (k, _) -> k <> key) leaves in
944
950
of_assoc t.blockstore ((key, cid) :: without)
945
951
946
-
(* delete an entry, returning a new canonical mst
947
-
doesn't persist changes *)
952
+
(* delete an entry, returning a new canonical mst *)
948
953
let delete t key : t Lwt.t =
949
954
Util.ensure_valid_key key ;
950
955
let%lwt leaves = leaves_of_root t in
···
1108
1113
end
1109
1114
1110
1115
module Inductive (M : Intf) = struct
1111
-
module Mem_mst = Make (Memory_blockstore)
1116
+
module Cache_bs = Cache_blockstore (Memory_blockstore)
1117
+
module Mem_mst = Make (Cache_bs)
1112
1118
1113
1119
type diff =
1114
1120
| Add of {key: string; cid: Cid.t}
···
1116
1122
| Delete of {key: string; prev: Cid.t}
1117
1123
1118
1124
(* given an mst diff, returns all new blocks as well as inductive proof blocks *)
1119
-
let generate_proof (curr : M.t) (diff : diff list) (prev_root : Cid.t) :
1125
+
let generate_proof (map : Cid.t String_map.t) (diff : diff list)
1126
+
~(new_root : Cid.t) ~(prev_root : Cid.t) :
1120
1127
((Cid.t * bytes) list, exn) Lwt_result.t =
1121
1128
try%lwt
1122
-
let%lwt map = M.build_map curr in
1123
1129
let%lwt mem_mst =
1124
-
Mem_mst.of_assoc (Memory_blockstore.create ()) (String_map.bindings map)
1130
+
Mem_mst.of_assoc
1131
+
(Cache_bs.create (Memory_blockstore.create ()))
1132
+
(String_map.bindings map)
1125
1133
in
1126
-
(* track all accessed cids relevant to inductive proof *)
1127
-
let accessed_cids = ref Cid.Set.empty in
1128
-
(* apply inverse of operations in reverse order *)
1129
-
let%lwt new_mst, added_cids =
1134
+
(* save this now so we can read blocks from it later *)
1135
+
let block_map = mem_mst.blockstore.bs.blocks in
1136
+
(* apply inverse of operations in reverse order,
1137
+
check that mst root matches prev_root *)
1138
+
let%lwt inverted_mst, added_cids =
1130
1139
Lwt_list.fold_right_s
1131
1140
(fun (diff : diff) (mst, added_cids) ->
1132
1141
match diff with
1133
1142
| Delete {key; prev} | Update {key; prev= Some prev; _} ->
1134
-
accessed_cids := Cid.Set.add prev !accessed_cids ;
1135
1143
let%lwt mst = Mem_mst.add mst key prev in
1136
1144
Lwt.return (mst, Cid.Set.remove prev added_cids)
1137
1145
| Add {key; cid} | Update {key; prev= None; cid} ->
1138
-
accessed_cids := Cid.Set.add cid !accessed_cids ;
1139
1146
let%lwt mst = Mem_mst.delete mst key in
1140
1147
Lwt.return (mst, Cid.Set.add cid added_cids) )
1141
1148
diff (mem_mst, Cid.Set.empty)
1142
1149
in
1143
-
if not (Cid.equal new_mst.root prev_root) then
1150
+
if not (Cid.equal inverted_mst.root prev_root) then
1144
1151
failwith
1145
1152
(Printf.sprintf
1146
1153
"inductive proof produced invalid previous cid: expected %s, got \
1147
1154
%s"
1148
1155
(Cid.to_string prev_root)
1149
-
(Cid.to_string new_mst.root) ) ;
1156
+
(Cid.to_string inverted_mst.root) ) ;
1150
1157
let proof_cids =
1151
-
Cid.Set.union added_cids !accessed_cids
1152
-
|> Cid.Set.remove prev_root |> Cid.Set.add new_mst.root
1158
+
Cid.Set.union added_cids mem_mst.blockstore.reads
1159
+
|> Cid.Set.remove prev_root |> Cid.Set.add new_root
1153
1160
in
1154
-
let%lwt {blocks= proof_bm; _} =
1155
-
Memory_blockstore.get_blocks mem_mst.blockstore
1156
-
(Cid.Set.elements proof_cids)
1161
+
let {blocks= proof_bm; _} : Block_map.with_missing =
1162
+
Block_map.get_many (Cid.Set.elements proof_cids) block_map
1157
1163
in
1158
1164
Lwt.return_ok (Block_map.entries proof_bm)
1159
1165
with e -> Lwt.return_error e
+2
mist/lib/storage/block_map.ml
+2
mist/lib/storage/block_map.ml
+37
mist/lib/storage/cache_blockstore.ml
+37
mist/lib/storage/cache_blockstore.ml
···
1
+
type 'bs data = {mutable reads: Cid.Set.t; bs: 'bs}
2
+
3
+
module Make
4
+
(Bs : Blockstore.Writable) : sig
5
+
include Blockstore.Writable
6
+
7
+
val create : Bs.t -> t
8
+
end
9
+
with type t = Bs.t data = struct
10
+
type t = Bs.t data
11
+
12
+
let create bs = {reads= Cid.Set.empty; bs}
13
+
14
+
let get_bytes t cid =
15
+
match%lwt Bs.get_bytes t.bs cid with
16
+
| Some _ as res ->
17
+
t.reads <- Cid.Set.add cid t.reads ;
18
+
Lwt.return res
19
+
| None ->
20
+
Lwt.return_none
21
+
22
+
let has t cid = Bs.has t.bs cid
23
+
24
+
let get_blocks t cids =
25
+
let%lwt bm = Bs.get_blocks t.bs cids in
26
+
t.reads <-
27
+
Cid.Set.union t.reads (Cid.Set.of_list (Block_map.keys bm.blocks)) ;
28
+
Lwt.return bm
29
+
30
+
let put_block t cid bytes = Bs.put_block t.bs cid bytes
31
+
32
+
let put_many t blocks = Bs.put_many t.bs blocks
33
+
34
+
let delete_block t cid = Bs.delete_block t.bs cid
35
+
36
+
let delete_many t cids = Bs.delete_many t.bs cids
37
+
end
+9
mist/lib/storage/storage.ml
+9
mist/lib/storage/storage.ml
···
23
23
24
24
module Readable : Blockstore.Readable with type t = Impl.t = Impl
25
25
end
26
+
27
+
module Cache_blockstore (Bs : Blockstore.Writable) = struct
28
+
module Impl = Cache_blockstore.Make (Bs)
29
+
include Impl
30
+
31
+
module Readable : Blockstore.Readable with type t = Impl.t = Impl
32
+
33
+
module Writable : Blockstore.Writable with type t = Impl.t = Impl
34
+
end
+6
-1
pegasus/lib/repository.ml
+6
-1
pegasus/lib/repository.ml
···
226
226
User_store.put_commit t.db signed |> Lwt_result.get_exn
227
227
in
228
228
t.commit <- Some (commit_cid, signed) ;
229
+
(* clear cached blocks so next get_map call rebuilds from the new commit *)
230
+
t.block_map <- None ;
229
231
Lwt.return (commit_cid, signed)
230
232
231
233
let put_initial_commit t : (Cid.t * signed_commit) Lwt.t =
···
401
403
[] !commit_ops
402
404
in
403
405
let%lwt proof_blocks =
404
-
match%lwt Inductive.generate_proof new_mst diff prev_commit.data with
406
+
match%lwt
407
+
Inductive.generate_proof !block_map diff ~new_root:new_mst.root
408
+
~prev_root:prev_commit.data
409
+
with
405
410
| Ok blocks ->
406
411
Lwt.return blocks
407
412
| Error err ->
+3
-1
pegasus/lib/xrpc.ml
+3
-1
pegasus/lib/xrpc.ml
···
38
38
try%lwt
39
39
let%lwt body = Dream.body req in
40
40
body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return
41
-
with _ -> Errors.invalid_request "Invalid request body"
41
+
with e ->
42
+
Errors.log_exn e ;
43
+
Errors.invalid_request "Invalid request body"
42
44
43
45
let service_proxy (ctx : context) (proxy_header : string) =
44
46
let did = Auth.get_authed_did_exn ctx.auth in