diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/Journal.ml | 198 | ||||
| -rw-r--r-- | lib/kernel/Journal.mli | 22 |
2 files changed, 0 insertions, 220 deletions
diff --git a/lib/kernel/Journal.ml b/lib/kernel/Journal.ml deleted file mode 100644 index 13782a5..0000000 --- a/lib/kernel/Journal.ml +++ /dev/null @@ -1,198 +0,0 @@ -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 diff --git a/lib/kernel/Journal.mli b/lib/kernel/Journal.mli deleted file mode 100644 index d354e03..0000000 --- a/lib/kernel/Journal.mli +++ /dev/null @@ -1,22 +0,0 @@ -(** a namespace that keeps its history: each binding it accepts is a - commit of [Protocols.Journal]. It answers [Directory] and [Registry] - as a plain namespace does, so a subsystem that only knows those - commits without knowing it. *) - -(** a journal whose first commit, numbered 0, binds [bindings]. *) -val make : ?bindings:(string * Protocols.Handle.t) list -> unit -> Protocols.Handle.t - -(** a journal whose first commit binds whatever [directory] binds now. *) -val adopt : Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result - -(** a directory of [bindings] that, asked for a derived relation, hands - it out read against itself. *) -val snapshot : (string * Protocols.Handle.t) list -> Protocols.Handle.t - -(** bind each name to its handle, or unbind it, whatever it was bound to - before: as one commit when [directory] is a journal, and one name at - a time when it is a plain namespace. *) -val rebind : - Protocols.Handle.t -> - (string * Protocols.Handle.t option) list -> - (unit, Concepts.Condition.condition) result |