blob: 3fd208e7c4952b2e94644fed06575a828514376f (
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
|
let mixture ps =
Protocols.Handle.make
@@ object
inherit Lifecycle.null
inherit Identity.of_id (* Should we allow the user to override this? *)
method protocols = ps
method to_string = "mixture"
end
let rec mixture_of value f = mixture (f (fun value' -> mixture_of value' f) value)
module Error = struct
open Concepts.Condition
let invalid_property key =
condition "invalid-property"
"The specified key does not correspond to any property of the object"
("key" |=| Concepts.Value.String key)
let deletion_not_supported () =
condition "deletion-not-supported" "Attempting to delete an object property" empty
end
module Addressable = struct
module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY) = struct
module Tree = Merkle.Make (S) (K)
let make ~node =
Protocols.Addressable.make
@@ object
method address = Tree.hash_of node
end
end
end
module Associative = struct
let of_properties props =
Protocols.Associative.make
@@ object
val props = BatList.to_seq props |> BatMap.of_seq
method update key value =
match BatMap.find_opt key props with
| None -> Error (Error.invalid_property key)
| Some f -> f value
end
let update_only f = function None -> Error (Error.deletion_not_supported ()) | Some x -> f x
type 'tx admission = 'tx -> (Concepts.Hash.hash, Concepts.Condition.condition) result
module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct
module Tree = Merkle.Make (S) (K)
module SI = Storage.Make (S)
(* A value with no address yet is [admit]ted: it is read here, before
the write begins, since reading it may itself need storage, and
stored by the write. *)
let make ?admit ~storage ~constructor ~node () =
Protocols.Associative.make
@@ object
method update key value =
let open Utilities.Result in
let open Protocols in
let* store =
match value with
| None -> Ok None
| Some h -> (
match Addressable.from h, admit with
| None, Some admit -> admit key h |> Result.map Option.some
| _ ->
let* addressable = Handle.require Addressable.from h in
let addr = Addressable.address addressable in
Ok (Some (fun _ -> Ok addr)) )
in
SI.with_transaction storage (fun tx ->
let* node' =
match store with
| None -> Tree.remove tx key node
| Some store ->
let* addr = store tx in
Tree.insert tx key addr node
in
constructor node' )
end
end
end
module Directory = struct
let of_properties props =
Protocols.Directory.make
@@ object
val props = BatList.to_seq props |> BatMap.of_seq
method list = Ok (BatMap.keys props |> BatFingerTree.of_enum)
method find k = Ok (BatMap.find_opt k props)
end
module OfTree
(S : Abstract.Storage.STORAGE)
(K : Merkle.KEY with type t = string)
(V : Merkle.VALUE) =
struct
module Tree = Merkle.Interface (S) (K) (V)
module SI = Storage.Make (S)
let make ~storage ~constructor ~node =
Protocols.Directory.make
@@ object
method list = SI.with_read storage (Fun.flip Tree.keys node)
method find k =
SI.with_read storage (fun tx -> Tree.lookup tx k node)
|> Utilities.Result.fmap (function
| None -> Ok None
| Some x -> constructor x |> Result.map Option.some )
end
end
end
|
