blob: 1417a65b9df59f3045b859c63968245205abc33e (
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
|
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module R = SubstantialRelation.Make (S)
module E = EphemeralRelation.Make (S)
module Entry = struct
module Stored = EphemeralRelation.Persisted.Representation
type t = Substantial of R.t | Ephemeral of EphemeralRelation.Persisted.t
let encode = function
| Substantial relation -> R.encode relation
| Ephemeral relation -> Stored.to_blob relation
let decode blob =
let open Utilities.Result in
let open Concepts.Encoding in
let* data = Bencode.of_blob blob in
match data with
| Bencode.Tagged (tag, _) when Char.equal tag Stored.tag ->
Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
| _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
let load storage = function
| Substantial relation -> R.load storage relation
| Ephemeral relation -> E.load storage relation
end
module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
type t = {relations: RelationM.address}
module Error = struct
open Concepts.Condition
let malformed_multigroup () =
condition "malformed-multigroup"
"The on-disk representation of a multigroup did not conform to what was expected. Is your \
database corrupted?"
empty
let incomplete_multigroup addr =
condition "incomplete-multigroup"
"A stored multigroup is missing part of its expected structure. Is your storage corrupted?"
("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
end
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 = '*'
let malformed = Error.malformed_multigroup
let fields {relations} =
let open Concepts.Encoding in
["relations", Value.bencode_of_hash relations]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
Ok {relations}
end
let encode = Representation.to_blob
let decode = Representation.of_blob
class multigroup conn value node =
object (self)
inherit Lifecycle.null
method to_string = "multigroup"
val multigroup = value
val storage = conn
val node = node (* FIXME: see the comment on Branch.ml *)
(* TODO: Add later to the lifecycle management, accounting for
derived instances. Callers must release the previous handle
when done with it so its instance can be cleaned up after the
last reference is released. *)
method deriving multigroup' =
let open Utilities.Result in
let* node' =
SI.with_transaction storage (fun tx ->
let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
RelationM.find tx multigroup'.relations
|> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
in
new multigroup storage multigroup' 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
[ ( "relation",
update_only (fun node' ->
Handle.require Addressable.from node'
|> Result.map Addressable.address
|> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
Prototype.Directory.of_properties
[ ( "relation",
Prototype.mixture_of node (fun make node ->
[ RMAddressable.make ~node:(RelationM.into node);
RMDirectory.make ~storage ~node ~constructor:(Entry.load storage);
RMAssociative.make ~storage ~node:(RelationM.into node)
~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
) ] ]
method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
method address = self#hash
end
let wrap conn value =
let open Utilities.Result in
let* node =
SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
|> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations))
in
new multigroup conn value node |> Protocols.Handle.make |> Result.ok
let make conn =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
let* empty = RelationM.empty_under tx in
let multigroup = {relations= empty} in
let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok )
end
|
