blob: 453000428f5185d1a0bb36afc50f03d433e145df (
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
|
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module Sc = Schema.Make (S)
module SchemaM = Merkle.Interface (S) (Merkle.StringKey) (Sc)
module SMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
module SMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Sc)
module SMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
type t = {schemas: SchemaM.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 {schemas} =
let open Concepts.Encoding in
["schemas", Value.bencode_of_hash schemas]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in
Ok {schemas}
end
let encode = Representation.to_blob
let decode = Representation.of_blob
let node_of tx multigroup =
let open Utilities.Result in
SchemaM.find tx multigroup.schemas
|> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup.schemas))
class multigroup ?bind 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
node_of tx multigroup' )
in
new multigroup ?bind 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
[ ( "schema",
update_only (fun node' ->
Handle.require Addressable.from node'
|> Result.map Addressable.address
|> fmap (fun addr -> self#deriving {schemas= addr}) ) ) ] );
Prototype.Directory.of_properties
[ ( "schema",
Prototype.mixture_of node (fun make node ->
[ SMAddressable.make ~node:(SchemaM.into node);
SMDirectory.make ~storage ~node ~constructor:(Sc.load ?bind storage);
SMAssociative.make ~admit:Sc.admit ~storage ~node:(SchemaM.into node)
~constructor:(fun node' -> SchemaM.from node' |> make |> Result.ok)
() ] ) ) ] ]
method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
method address = self#hash
end
let load ?bind conn value =
let open Utilities.Result in
let* node = SI.with_read conn (fun tx -> node_of tx value) in
new multigroup ?bind conn value node |> Protocols.Handle.make |> Result.ok
let make conn =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
let* empty = SchemaM.empty_under tx in
let multigroup = {schemas= empty} in
let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
new multigroup conn multigroup SchemaM.empty |> Protocols.Handle.make |> Result.ok )
(* Handed over as the tree shows one, a directory holding its schemas
under \schema, a multigroup not stored yet is stored with them. *)
let admit _ h =
let open Utilities.Result in
let* listing = Protocols.Handle.require Protocols.Directory.from h in
let* schemas = Protocols.Directory.find listing "schema" in
let* schemas =
match schemas with
| None -> Ok []
| Some schemas ->
let* listing = Protocols.Handle.require Protocols.Directory.from schemas in
let* names = Protocols.Directory.list listing in
BatFingerTree.to_list names
|> List.filter_map (fun name ->
match Protocols.Directory.find listing name with
| Ok None -> None
| Error c -> Some (Error c)
| Ok (Some schema) -> (
match Protocols.Addressable.from schema with
| Some a ->
let addr = Protocols.Addressable.address a in
Some (Ok (name, fun _ -> Ok addr))
| None -> Some (Sc.admit name schema |> Result.map (fun p -> name, p)) ) )
|> Utilities.List.sequence
in
Ok
(fun tx ->
let* _ = SchemaM.empty_under tx in
let* node =
SchemaM.with_batch tx (fun () ->
List.fold_left
(fun node (name, store) ->
let* node = node in
let* addr = store tx in
SchemaM.Tree.insert tx name addr (SchemaM.into node) |> Result.map SchemaM.from )
(Ok SchemaM.empty) schemas )
in
SI.store_blob tx (Representation.to_blob {schemas= SchemaM.hash_of node}) )
end
|
