objective categorical abstract machine language personal data server
Basic MST
+263
-7
+2
dune-project
+2
dune-project
+6
ipld/lib/cid.ml
+6
ipld/lib/cid.ml
+2
mist.opam
+2
mist.opam
+3
-1
mist/lib/dune
+3
-1
mist/lib/dune
+244
mist/lib/mst.ml
+244
mist/lib/mst.ml
···
1
+
module StringMap = Dag_cbor.StringMap
2
+
3
+
type node_raw =
4
+
{ (* link to lower level left subtree with all keys sorting before this node *)
5
+
l: Cid.t option
6
+
; (* ordered list of entries below this node *)
7
+
e: entry_raw list }
8
+
9
+
and entry_raw =
10
+
{ (* length of prefix shared with previous path *)
11
+
p: int
12
+
; (* remainder of path for this entry, after the first p characters *)
13
+
k: bytes
14
+
; (* link to the CBOR record data for this entry *)
15
+
v: Cid.t
16
+
; (* link to lower level right subtree with all keys sorting after this entry, but before the next entry *)
17
+
t: Cid.t option }
18
+
19
+
let encode_entry_raw entry : Dag_cbor.value =
20
+
`Map
21
+
(StringMap.of_list
22
+
[ ("p", `Integer (Int64.of_int entry.p))
23
+
; ("k", `Bytes entry.k)
24
+
; ("v", `Link entry.v)
25
+
; ("t", match entry.t with Some t -> `Link t | None -> `Null) ] )
26
+
27
+
let encode_node_raw node : Dag_cbor.value =
28
+
`Map
29
+
(StringMap.of_list
30
+
[ ("l", match node.l with Some l -> `Link l | None -> `Null)
31
+
; ("e", `Array (Array.of_list (List.map encode_entry_raw node.e))) ] )
32
+
33
+
type node_hydrated =
34
+
{ layer: int
35
+
; mutable left: node_hydrated option
36
+
; mutable entries: entry_hydrated list }
37
+
38
+
and entry_hydrated =
39
+
{layer: int; key: string; value: Cid.t; right: node_hydrated option}
40
+
41
+
module Make (Store : Storage.Writable_blockstore) = struct
42
+
type bs = Store.t
43
+
44
+
type t = {blockstore: bs; root: Cid.t}
45
+
46
+
let create blockstore root = {blockstore; root}
47
+
48
+
let decode_block b : node_raw =
49
+
match Dag_cbor.decode b with
50
+
| `Map node ->
51
+
if not (StringMap.mem "e" node) then
52
+
raise (Invalid_argument "mst node missing 'e'") ;
53
+
let l =
54
+
if StringMap.mem "l" node then
55
+
match StringMap.find "l" node with `Link l -> Some l | _ -> None
56
+
else None
57
+
in
58
+
let e_array =
59
+
match StringMap.find "e" node with `Array e -> e | _ -> [||]
60
+
in
61
+
let e =
62
+
Array.to_list
63
+
@@ Array.map
64
+
(fun (entry : Dag_cbor.value) ->
65
+
match entry with
66
+
| `Map entry ->
67
+
{ p=
68
+
( entry |> StringMap.find "p"
69
+
|> function
70
+
| `Integer p ->
71
+
Int64.to_int p
72
+
| _ ->
73
+
raise (Invalid_argument "mst entry missing 'p'") )
74
+
; k=
75
+
( entry |> StringMap.find "k"
76
+
|> function
77
+
| `Bytes k ->
78
+
k
79
+
| _ ->
80
+
raise (Invalid_argument "mst entry missing 'k'") )
81
+
; v=
82
+
( entry |> StringMap.find "v"
83
+
|> function
84
+
| `Link v ->
85
+
v
86
+
| _ ->
87
+
raise (Invalid_argument "mst entry missing 'v'") )
88
+
; t=
89
+
( entry |> StringMap.find "t"
90
+
|> function `Link t -> Some t | _ -> None ) }
91
+
| _ ->
92
+
raise (Invalid_argument "non-map mst entry") )
93
+
e_array
94
+
in
95
+
{l; e}
96
+
| _ ->
97
+
raise (Invalid_argument "invalid block")
98
+
99
+
let retrieve_node t cid : node_raw option Lwt.t =
100
+
match%lwt Store.get_bytes t.blockstore cid with
101
+
| Some bytes ->
102
+
Lwt.return_some (decode_block bytes)
103
+
| None ->
104
+
Lwt.return_none
105
+
106
+
let rec get_node_height t node : int Lwt.t =
107
+
match (node.l, node.e) with
108
+
| None, [] ->
109
+
Lwt.return 0
110
+
| Some left, [] -> (
111
+
match%lwt retrieve_node t left with
112
+
| Some node ->
113
+
let%lwt height = get_node_height t node in
114
+
Lwt.return (height + 1)
115
+
| None ->
116
+
failwith ("couldn't find node " ^ Cid.to_string left) )
117
+
| _, leaf :: _ -> (
118
+
match leaf.p with
119
+
| 0 ->
120
+
Lwt.return (Util.leading_zeros_on_hash (Bytes.to_string leaf.k))
121
+
| _ ->
122
+
failwith "first node entry has nonzero p value" )
123
+
124
+
let traverse t fn : unit Lwt.t =
125
+
let rec traverse node =
126
+
let%lwt () =
127
+
match node.l with
128
+
| Some cid -> (
129
+
match%lwt retrieve_node t cid with
130
+
| Some node ->
131
+
traverse node
132
+
| None ->
133
+
Lwt.return_unit )
134
+
| None ->
135
+
Lwt.return_unit
136
+
in
137
+
ignore
138
+
(List.fold_left
139
+
(fun prev_path entry ->
140
+
let prefix = String.sub prev_path 0 entry.p in
141
+
let path = String.concat "" [prefix; Bytes.to_string entry.k] in
142
+
fn path entry.v ; path )
143
+
"" node.e ) ;
144
+
Lwt.return_unit
145
+
in
146
+
match%lwt retrieve_node t t.root with
147
+
| Some root ->
148
+
traverse root
149
+
| None ->
150
+
failwith "root cid not found in repo store"
151
+
152
+
let build_map t : Cid.t StringMap.t Lwt.t =
153
+
let map = StringMap.empty in
154
+
let%lwt () =
155
+
traverse t (fun path cid -> ignore (StringMap.add path cid map))
156
+
in
157
+
Lwt.return map
158
+
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 =
191
+
let keys =
192
+
map |> StringMap.bindings |> List.map fst |> List.sort String.compare
193
+
in
194
+
let entry_for_key key =
195
+
let value = StringMap.find key map in
196
+
let height = Util.leading_zeros_on_hash key in
197
+
{layer= height; key; value; right= None}
198
+
in
199
+
let root =
200
+
{ layer= keys |> List.hd |> Util.leading_zeros_on_hash
201
+
; entries= []
202
+
; left= None }
203
+
in
204
+
List.iter
205
+
(fun key -> ignore (insert_entry root (entry_for_key key)))
206
+
(List.tl keys) ;
207
+
let rec finalize node : Cid.t Lwt.t =
208
+
let left =
209
+
match node.left with
210
+
| Some l ->
211
+
Some (Lwt_main.run (finalize l))
212
+
| None ->
213
+
None
214
+
in
215
+
let last_key = ref "" in
216
+
let mst_entries =
217
+
List.map
218
+
(fun entry ->
219
+
let right =
220
+
match entry.right with
221
+
| Some r ->
222
+
Some (Lwt_main.run (finalize r))
223
+
| None ->
224
+
None
225
+
in
226
+
let prefix_len = Util.shared_prefix_length !last_key entry.key in
227
+
last_key := entry.key ;
228
+
{ k=
229
+
Bytes.of_string
230
+
(String.sub entry.key prefix_len
231
+
(String.length entry.key - prefix_len) )
232
+
; p= prefix_len
233
+
; v= entry.value
234
+
; t= right } )
235
+
node.entries
236
+
in
237
+
let mst_node = {l= left; e= mst_entries} in
238
+
let encoded = Dag_cbor.encode (encode_node_raw mst_node) in
239
+
let cid = Cid.create Dcbor encoded in
240
+
let%lwt () = Store.put_block t.blockstore cid encoded in
241
+
Lwt.return cid
242
+
in
243
+
finalize root
244
+
end
+4
-4
mist/lib/storage/memory_store.ml
+4
-4
mist/lib/storage/memory_store.ml
···
12
12
13
13
let get_blocks s cids = Lwt.return (Block_map.get_many cids s.blocks)
14
14
15
-
let put_block s cid bytes ~rev =
15
+
let put_block s ?rev cid bytes =
16
16
s.blocks <- Block_map.set cid bytes s.blocks ;
17
-
s.rev <- Some rev ;
17
+
s.rev <- rev ;
18
18
Lwt.return_unit
19
19
20
20
let put_many s blocks =
21
21
s.blocks <- Block_map.merge s.blocks blocks ;
22
22
Lwt.return_unit
23
23
24
-
let update_root s cid ~rev =
24
+
let update_root s ?rev cid =
25
25
s.root <- Some cid ;
26
-
s.rev <- Some rev ;
26
+
s.rev <- rev ;
27
27
Lwt.return_unit
28
28
29
29
let apply_commit s (c : Repo_store.commit_data) =
+2
-2
mist/lib/storage/repo_store.ml
+2
-2
mist/lib/storage/repo_store.ml
···
21
21
22
22
include Readable with type t := t
23
23
24
-
val put_block : t -> Cid.t -> bytes -> rev:string -> unit Lwt.t
24
+
val put_block : t -> ?rev:string -> Cid.t -> bytes -> unit Lwt.t
25
25
26
26
val put_many : t -> Block_map.t -> unit Lwt.t
27
27
28
-
val update_root : t -> Cid.t -> rev:string -> unit Lwt.t
28
+
val update_root : t -> ?rev:string -> Cid.t -> unit Lwt.t
29
29
30
30
val apply_commit : t -> commit_data -> unit Lwt.t
31
31
end