blob: 01675f05bc9b0dae869499fed434eeff85b73341 (
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
|
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 *)
method protocols : Protocols.Handle.protocol list =
Protocols.
[ Addressable.make self;
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
|
