blob: 31442f611205505ec0024cc4f8fb623b11758aaf (
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
|
module Multigroup = Merkle.StringKey (* FIXME *)
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 MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (Multigroup)
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 load tx addr =
SI.get_req tx addr
|> Utilities.Result.fmap Representation.of_blob
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 (Fun.flip (SI.Pointer.make) load))) in
Ok { multigroups; previous }
end
class branch storage value = object
inherit Lifecycle.null
val storage : S.connection = storage
val branch : t = value
method protocols : Protocols.Handle.protocol list = []
method hash =
Representation.to_blob branch
|> Concepts.Hash.hash_of_blob
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
Ok (new branch conn branch |> Protocols.Handle.make)
let make conn =
let open Utilities.Result in
let* empty = SI.with_transaction conn MultigroupM.empty_under in
Ok (new branch conn { multigroups = empty; previous = None } |> Protocols.Handle.make)
end
|
