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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
module J = Protocols.Journal
module Bindings = BatMap.String
module Error = struct
open Concepts.Condition
let empty_commit () = condition "empty-commit" "A commit has to change at least one name" empty
let repeated_name name =
condition "repeated-name" "A commit names the same binding twice"
("name" |=| Concepts.Value.String name)
end
(* A snapshot is named by its bindings, so two snapshots binding the
same objects are the same snapshot. *)
let identity bindings =
Bindings.fold
(fun name handle acc ->
name :: Concepts.Hash.to_raw_string (Protocols.Handle.hash handle) :: acc )
bindings []
|> String.concat "\000"
|> Bytes.of_string
|> Concepts.Hash.hash_of_bytes
class snapshot bindings =
object (self)
inherit Lifecycle.null
method to_string = "snapshot"
method hash = identity bindings
val mutable handle : Protocols.Handle.t option = None
method protocols : Protocols.Handle.protocol list = [Protocols.Directory.make self]
method list = Ok (Bindings.keys bindings |> BatFingerTree.of_enum)
method find name =
match Bindings.find_opt name bindings with
| None -> Ok None
| Some bound -> (
match Protocols.Derived.from bound, handle with
| Some derived, Some me -> Protocols.Derived.within derived me |> Result.map Option.some
| _ -> Ok (Protocols.Handle.copy bound) )
method attach me = handle <- Some me
end
let snapshot_of bindings =
let o = new snapshot bindings in
let handle = Protocols.Handle.make o in
o#attach handle; handle
let snapshot bindings = snapshot_of (Bindings.of_list bindings)
type state = {commit: J.commit; bindings: Protocols.Handle.t Bindings.t}
class journal bindings =
object (self)
inherit Lifecycle.null
inherit Identity.of_id
method to_string = "journal"
val lock = Mutex.create ()
(* the latest first *)
val mutable states =
[ { commit=
{ J.number= 0;
snapshot= snapshot_of bindings;
changed= Bindings.keys bindings |> BatList.of_enum };
bindings } ]
val mutable guards : (string * J.guard) list = []
val mutable observers : (string * J.observer) list = []
method protocols : Protocols.Handle.protocol list =
Protocols.[Directory.make self; Registry.make self; J.make self]
method head = (List.hd states).commit
method history = List.rev_map (fun {commit; _} -> commit) states
method guard name g =
Mutex.protect lock (fun () ->
guards <-
List.remove_assoc name guards @ Option.fold ~none:[] ~some:(fun g -> [name, g]) g )
method observe name f =
Mutex.protect lock (fun () ->
observers <-
List.remove_assoc name observers @ Option.fold ~none:[] ~some:(fun f -> [name, f]) f )
method list = Ok (Bindings.keys (List.hd states).bindings |> BatFingerTree.of_enum)
method find name =
Ok
( Bindings.find_opt name (List.hd states).bindings
|> Utilities.Option.fmap Protocols.Handle.copy )
method update name expected replacement =
self#commit [{J.name; expected; replacement}] |> Result.map Option.is_some
(* Guards run in the order they were installed, and observers after
the commit has landed, both while holding the journal, so they
see commits one at a time and in order. *)
method commit (changes : J.change list) =
let open Utilities.Result in
let names = List.map (fun (c : J.change) -> c.name) changes in
let repeated =
List.find_opt (fun n -> List.length (List.filter (String.equal n) names) > 1) names
in
match changes, repeated with
| [], _ -> Error (Error.empty_commit ())
| _, Some name -> Error (Error.repeated_name name)
| _ ->
Mutex.protect lock (fun () ->
let current = List.hd states in
let expected (c : J.change) =
Bindings.find_opt c.name current.bindings = c.expected
in
if not (List.for_all expected changes) then Ok None
else
let bindings =
List.fold_left
(fun bindings (c : J.change) ->
match c.replacement with
| Some h -> Bindings.add c.name h bindings
| None -> Bindings.remove c.name bindings )
current.bindings changes
in
let commit =
{ J.number= current.commit.number + 1;
snapshot= snapshot_of bindings;
changed= names }
in
let proposal = {J.previous= current.commit; proposed= commit} in
let* () =
List.fold_left
(fun acc (_, g) ->
let* () = acc in
g proposal )
(Ok ()) guards
in
states <- {commit; bindings} :: states;
List.iter (fun (_, f) -> f commit) observers;
Ok (Some commit) )
end
let make ?(bindings = []) () = Protocols.Handle.make (new journal (Bindings.of_list bindings))
let adopt directory =
let open Utilities.Result in
let* listing = Protocols.Handle.require Protocols.Directory.from directory in
let* names = Protocols.Directory.list listing in
let* bindings =
BatFingerTree.to_list names
|> List.map (fun name ->
let* found = Protocols.Directory.find listing name in
Ok (Option.map (fun h -> name, h) found) )
|> Utilities.List.sequence
in
Ok (make ~bindings:(List.filter_map Fun.id bindings) ())
(* What a name is bound to is read as a copy, which has to stay valid
until the swap has compared against it. *)
let rebind directory bindings =
let open Utilities.Result in
let* listing = Protocols.Handle.require Protocols.Directory.from directory in
let holding names f =
let* found =
List.map (fun name -> Protocols.Directory.find listing name) names |> Utilities.List.sequence
in
Fun.protect
~finally:(fun () -> List.iter (Option.iter Protocols.Handle.release) found)
(fun () -> f found)
in
let rec together journal =
let* landed =
holding (List.map fst bindings) (fun found ->
List.map2
(fun (name, replacement) expected -> {J.name; expected; replacement})
bindings found
|> J.commit journal )
in
match landed with Some _ -> Ok () | None -> together journal
in
let rec one registry name replacement =
let* swapped =
holding [name] (fun found ->
Protocols.Registry.update registry name (List.hd found) replacement )
in
if swapped then Ok () else one registry name replacement
in
match J.from directory, bindings with
| _, [] -> Ok ()
| Some journal, _ -> together journal
| None, _ ->
let* registry = Protocols.Handle.require Protocols.Registry.from directory in
List.fold_left
(fun acc (name, replacement) ->
let* () = acc in
one registry name replacement )
(Ok ()) bindings
|
