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
