blob: 185f12ca0c662b23c3ebf549e2ad7d0c375088c8 (
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
|
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
(* 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 admission admit key h =
match Protocols.Addressable.from h with
| Some a ->
let addr = Protocols.Addressable.address a in
Ok (fun _ -> Ok addr)
| None -> admit key h
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)
let make ~admit ~storage ~constructor ~node =
Protocols.Associative.make
@@ object
method update key value =
let open Utilities.Result in
let* store =
match value with
| None -> Ok None
| Some h -> admission admit key h |> Result.map Option.some
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 = match BatMap.find_opt k props with None -> Ok None | Some f -> f ()
end
let of_properties props =
List.map (fun (p, h) -> p, fun () -> Ok (Some h)) props |> of_properties'
let children directory =
let open Utilities.Result in
let* listing = Protocols.Handle.require Protocols.Directory.from directory in
let* names = Protocols.Directory.list listing in
BatFingerTree.to_list names
|> List.map (fun name ->
let* found = Protocols.Directory.find listing name in
Ok (Option.map (fun child -> name, child) found) )
|> Utilities.List.sequence
|> Result.map (List.filter_map Fun.id)
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 =
let open Utilities.Result in
SI.with_read storage (fun tx -> Tree.lookup tx k node)
|>> function None -> Ok None | Some x -> constructor x |> Result.map Option.some
end
end
end
|
