journal for the websitejournal

2 files changed, 220 insertions, 0 deletions

diff --git a/lib/kernel/Journal.ml b/lib/kernel/Journal.ml
new file mode 100644
index 0000000..13782a5
--- /dev/null
+++ b/lib/kernel/Journal.ml
@@ -0,0 +1,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
diff --git a/lib/kernel/Journal.mli b/lib/kernel/Journal.mli
new file mode 100644
index 0000000..d354e03
--- /dev/null
+++ b/lib/kernel/Journal.mli
@@ -0,0 +1,22 @@
+(** 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