blob: 70e07113583b39e6a6fcd2cd3f26d3f359b30172 (
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
module Make (S : Abstract.Storage.STORAGE) = struct
(* A branch state holds its multigroups and a backlink to the state it
succeeded, each multigroup its relations:
\system\branch\master\multigroup\universe\relation\planet
\system\branch\master\previous\multigroup\universe\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)
let node_of tx branch =
let open Utilities.Result in
MultigroupM.find tx branch.multigroups
|> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
(* Given [root], the stored programs of this state run through the
evaluators registered under it, against this very state, so an
earlier state reads as it was. *)
class branch ?root 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
node_of tx branch' )
in
new branch ?root storage branch'' node' |> Protocols.Handle.make |> Result.ok
method private previous =
match branch.previous with
| None -> Ok None
| Some pointer ->
SI.with_read storage (fun tx ->
let open Utilities.Result in
let* previous = SI.Pointer.deref tx pointer in
let* node = node_of tx previous in
Ok (Some (Protocols.Handle.make {<branch = previous; node>})) )
method protocols : Protocols.Handle.protocol list =
let bind =
Option.map (fun root -> Source.bind root ~within:(Protocols.Handle.make {<>})) root
in
let multigroups =
Prototype.mixture_of node (fun make node ->
[ MMAddressable.make ~node:(MultigroupM.into node);
MMDirectory.make ~storage ~node ~constructor:(M.load ?bind storage);
MMAssociative.make ~admit:M.admit ~storage ~node:(MultigroupM.into node)
~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok ) ] )
in
let open Utilities.Result in
let admits (m, multigroup) =
Protocols.Handle.releasing multigroup (fun () ->
let* admission = Protocols.Admission.require multigroup in
let* violations = Protocols.Admission.check admission in
Ok
(List.map
(fun (d, tuples) ->
Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), tuples )
violations ) )
in
Protocols.
[ Addressable.make self;
Admission.make
object
method check =
let* named = Prototype.Directory.children multigroups in
List.map admits named |> Utilities.List.sequence |> Result.map List.concat
end;
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}) ) ) ] );
Directory.make
object
method list =
Ok
(BatFingerTree.of_list
( "multigroup"
:: Option.fold ~none:[] ~some:(fun _ -> ["previous"]) branch.previous ) )
method find =
function
| "multigroup" -> Ok (Some multigroups)
| "previous" -> self#previous
| _ -> Ok None
end ]
method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob
method address = self#hash
end
let load ?root 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 = node_of tx branch in
Ok (new branch ?root 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
|
