blob: b0ba06ee003805a283636eb658636f69658c55d4 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
module Make (S : Abstract.Storage.STORAGE) = struct
(* Branch has a name, a set of multigroups, and a backlink to the previous state
multigroup has a name and a set of schemas
schema has a name and a set of relations
\branch\master\multigroup\universe\schema\sky\relation\planet
*)
module SI = Storage.Make (S)
module M = Multigroup.Make (S)
module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (M)
module MMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (M)
module MMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
module MMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
module Error = struct
open Concepts.Condition
let incomplete_branch addr =
condition "incomplete-branch"
"A stored branch is missing part of its expected structure. Is your storage corrupted?"
("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
end
type t = {multigroups: MultigroupM.address; previous: t SI.Pointer.t option}
module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
Concepts.Encoding.Record.Make (Body)
and Body : Concepts.Encoding.Record.BODY = struct
type nonrec t = t
let tag = 'Y'
let malformed () =
Concepts.Condition.(
condition "malformed-branch"
"The on-disk representation of a branch did not conform to what was expected. Is your \
database corrupted?"
empty )
let fields {multigroups; previous} =
let open Concepts.Encoding in
[ "multigroups", Value.bencode_of_hash multigroups;
( "previous",
Value.bencode_of_option
(fun v -> SI.Pointer.address_of v |> SI.as_hash |> Value.bencode_of_hash)
previous ) ]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* multigroups = Bencode.field "multigroups" fields |> fmap Value.hash_of_bencode in
let* previous =
Bencode.field "previous" fields
|> fmap
(Value.option_of_bencode (fun v ->
Value.hash_of_bencode v
|> Result.map (fun hash -> S.Hash hash)
|> Result.map (SI.Pointer.make Loader.load) ) )
in
Ok {multigroups; previous}
end
and Loader : sig
val load : S.transaction -> S.address -> (t, Concepts.Condition.condition) result
end = struct
let load tx addr = SI.get_req tx addr |> Utilities.Result.fmap Representation.of_blob
end
let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash)
class branch storage value node =
object (self)
inherit Lifecycle.null
method to_string = "branch"
val storage : S.connection = storage
val branch : t = value
val node = node (* FIXME: can we not place this inside `t`? *)
method deriving branch' =
let open Utilities.Result in
let branch'' = {branch' with previous= self#address |> pointer_of |> Option.some} in
let* node' =
SI.with_transaction storage (fun tx ->
let* _ = SI.store_blob tx (Representation.to_blob branch'') in
MultigroupM.find tx branch'.multigroups
|> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups)) )
in
new branch storage branch'' node' |> Protocols.Handle.make |> Result.ok
method protocols : Protocols.Handle.protocol list =
let open Utilities.Result in
Protocols.
[ Addressable.make self;
Prototype.Associative.(
of_properties
[ ( "multigroup",
update_only (fun node' ->
Handle.require Addressable.from node'
|> Result.map Addressable.address
|> fmap (fun addr -> self#deriving {branch with multigroups= addr}) ) ) ] );
Prototype.Directory.of_properties
[ ( "multigroup",
Prototype.mixture_of node (fun make node ->
[ MMAddressable.make ~node:(MultigroupM.into node);
MMDirectory.make ~storage ~node ~constructor:(M.wrap storage);
MMAssociative.make ~storage ~node:(MultigroupM.into node)
~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok )
] ) ) ] ]
method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob
method address = self#hash
end
let load tx conn addr =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash addr) in
let* branch = Representation.of_blob data in
let* node =
MultigroupM.find tx branch.multigroups
|> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
in
Ok (new branch conn branch node |> Protocols.Handle.make)
let make conn =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
let* empty = MultigroupM.empty_under tx in
let branch = {multigroups= empty; previous= None} in
let* _ = SI.store_blob tx (Representation.to_blob branch) in
Ok (new branch conn branch MultigroupM.empty |> Protocols.Handle.make) )
end
|
