Initialization with Branch State and Index

7 files changed, 295 insertions, 0 deletions

diff --git a/lib/concepts/BranchState.ml b/lib/concepts/BranchState.ml
new file mode 100644
index 0000000..e8c6636
--- /dev/null
+++ b/lib/concepts/BranchState.ml
@@ -0,0 +1,87 @@
+type address = Hash.hash
+
+(* A branch state records durable branch data only. The runtime registry paths
+   mounted around it, such as /system/branches/master, are derived at
+   initialization and should not be persisted as part of [current]. *)
+type t = {current: address; history: address; tip: address option}
+
+module Field = struct
+  let current = "current"
+  let history = "history"
+  let tip = "tip"
+end
+
+module Error = struct
+  open Condition
+
+  let malformed_branch_state () =
+    condition "branch-state-malformed"
+      "A branch state representation did not conform to what was expected" empty
+
+  let malformed_hash length =
+    condition "branch-state-malformed-hash" "A branch state address was not a valid hash"
+      ("length" |=| Value.Integer length)
+end
+
+let make ~current ~history ~tip = {current; history; tip}
+let current branch_state = branch_state.current
+let history branch_state = branch_state.history
+let tip branch_state = branch_state.tip
+let address_bencode address = Object.Field.address address
+
+let address_option_bencode = function
+  | None -> Codec.Bencode.List []
+  | Some address -> Codec.Bencode.List [address_bencode address]
+
+let require_address_bencode = function
+  | Codec.Bencode.String raw ->
+      if String.length raw = Hash.size then Ok (Hash.of_raw_string raw)
+      else Error (Error.malformed_hash (String.length raw))
+  | _ -> Error (Error.malformed_branch_state ())
+
+let require_address_option key data =
+  let open Utilities.Result in
+  let* value = Codec.Bencode.field key data in
+  let* entries = Codec.Bencode.as_list value in
+  match entries with
+  | [] -> Ok None
+  | [value] ->
+      let* address = require_address_bencode value in
+      Ok (Some address)
+  | _ -> Error (Error.malformed_branch_state ())
+
+let equal_address_option left right =
+  match left, right with
+  | None, None -> true
+  | Some left, Some right -> Hash.hash_equals left right
+  | _ -> false
+
+module Body = struct
+  type nonrec t = t
+
+  let tag = 's'
+  let malformed = Error.malformed_branch_state
+
+  let equal left right =
+    Hash.hash_equals left.current right.current
+    && Hash.hash_equals left.history right.history
+    && equal_address_option left.tip right.tip
+
+  let fields branch_state =
+    [ Field.current, address_bencode branch_state.current;
+      Field.history, address_bencode branch_state.history;
+      Field.tip, address_option_bencode branch_state.tip ]
+
+  let of_fields data =
+    let open Utilities.Result in
+    let* current =
+      Object.Field.require_address ~malformed:Error.malformed_hash Field.current data
+    in
+    let* history =
+      Object.Field.require_address ~malformed:Error.malformed_hash Field.history data
+    in
+    let* tip = require_address_option Field.tip data in
+    Ok {current; history; tip}
+end
+
+include (Object.Codec.Make (Body) : Object.S with type t := t)
diff --git a/lib/concepts/BranchState.mli b/lib/concepts/BranchState.mli
new file mode 100644
index 0000000..45792cc
--- /dev/null
+++ b/lib/concepts/BranchState.mli
@@ -0,0 +1,17 @@
+type t
+type address = Hash.hash
+
+include Object.S with type t := t
+
+(** Durable state of one branch head.
+
+    [current] is the branch-visible catalog root, not the runtime namespace
+    rooted at [/system]. Runtime scaffolding is rebuilt during initialization.
+    [history] is the ordered commit-stream tree root. [tip] is absent until the
+    first real commit, so initialization does not create a synthetic commit just
+    to make the branch non-empty. *)
+val make : current:address -> history:address -> tip:address option -> t
+
+val current : t -> address
+val history : t -> address
+val tip : t -> address option
diff --git a/lib/kernel/BranchIndex.ml b/lib/kernel/BranchIndex.ml
new file mode 100644
index 0000000..d1efa9a
--- /dev/null
+++ b/lib/kernel/BranchIndex.ml
@@ -0,0 +1,29 @@
+type address = Concepts.Hash.hash
+type root = address
+type branch_name = string
+type branch_state_root = address
+
+let default_branch_name = "master"
+
+module Branch_name = struct
+  type t = branch_name
+
+  let encode name = Concepts.Codec.Bencode.(String name |> to_blob)
+  let compare left right = Concepts.Ordering.of_int (String.compare left right)
+
+  let decode blob =
+    Concepts.Codec.Bencode.of_blob blob |> Utilities.Result.fmap Concepts.Codec.Bencode.as_string
+end
+
+module Make (Store : Abstract.Storage.STORAGE) = struct
+  module Tree = Merkle.Make (Store) (Branch_name)
+
+  type tree = Tree.node
+
+  let empty = Tree.empty
+  let hash_of = Tree.hash_of
+  let persist = Tree.persist
+  let find = Tree.find
+  let find_branch = Tree.lookup
+  let put_branch = Tree.insert
+end
diff --git a/lib/kernel/BranchIndex.mli b/lib/kernel/BranchIndex.mli
new file mode 100644
index 0000000..5a867bf
--- /dev/null
+++ b/lib/kernel/BranchIndex.mli
@@ -0,0 +1,28 @@
+type address = Concepts.Hash.hash
+type root = address
+type branch_name = string
+type branch_state_root = address
+
+val default_branch_name : branch_name
+
+module Make (Store : Abstract.Storage.STORAGE) : sig
+  type tree
+
+  val empty : tree
+  val hash_of : tree -> root
+  val persist : Store.transaction -> tree -> (root, Concepts.Condition.condition) result
+  val find : Store.transaction -> root -> (tree option, Concepts.Condition.condition) result
+
+  val find_branch :
+    Store.transaction ->
+    branch_name ->
+    tree ->
+    (branch_state_root option, Concepts.Condition.condition) result
+
+  val put_branch :
+    Store.transaction ->
+    branch_name ->
+    branch_state_root ->
+    tree ->
+    (tree, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml
new file mode 100644
index 0000000..767dcca
--- /dev/null
+++ b/lib/kernel/Initialization.ml
@@ -0,0 +1,122 @@
+type address = Concepts.Hash.hash
+type branch_index_root = address
+
+let fixed_label = "rnt.initialization"
+let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label)
+
+module Error = struct
+  open Concepts.Condition
+
+  let malformed_address length =
+    condition "initialization-malformed-address"
+      "The initialization fixed key does not contain a valid address"
+      ("length" |=| Concepts.Value.Integer length)
+
+  let missing_branch_index address =
+    condition "initialization-branch-index-missing"
+      "The initialization fixed key points at a missing branch index"
+      ("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address))
+end
+
+let address_to_blob address =
+  Concepts.Object.Field.address address |> Concepts.Codec.Bencode.to_blob
+
+let address_of_blob blob =
+  let open Utilities.Result in
+  let* data = Concepts.Codec.Bencode.of_blob blob in
+  let* raw = Concepts.Codec.Bencode.as_string data in
+  if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw)
+  else Error (Error.malformed_address (String.length raw))
+
+module Make (Store : Abstract.Storage.STORAGE) = struct
+  module Branch_index = BranchIndex.Make (Store)
+
+  let finish tx = function
+    | Ok value ->
+        let open Utilities.Result in
+        let* () = Store.commit tx in
+        Ok value
+    | Error condition ->
+        let _ = Store.abort tx in
+        Error condition
+
+  let with_transaction connection body =
+    let open Utilities.Result in
+    let* tx = Store.start connection in
+    body tx |> finish tx
+
+  let read_in_transaction tx =
+    let open Utilities.Result in
+    let* fixed = Store.get tx fixed_label_address in
+    match fixed with
+    | None -> Ok None
+    | Some fixed ->
+        let* root = address_of_blob fixed in
+        let* branch_index = Branch_index.find tx root in
+        begin match branch_index with
+        | Some _ -> Ok (Some root)
+        | None -> Error (Error.missing_branch_index root)
+        end
+
+  let store_blob tx blob =
+    let open Utilities.Result in
+    let address = Concepts.Hash.hash_of_blob blob in
+    let* () = Store.put tx address blob in
+    Ok address
+
+  let store_fixed_root tx root = Store.put tx fixed_label_address (address_to_blob root)
+
+  let create_initial_branch_state tx =
+    let open Utilities.Result in
+    (* The first branch state has no synthetic "genesis" commit. Both [current]
+       and [history] point at persisted empty trees; the runtime mounts /system
+       around those roots after initialization. *)
+    let* empty_root = Branch_index.persist tx Branch_index.empty in
+    Concepts.BranchState.make ~current:empty_root ~history:empty_root ~tip:None
+    |> Concepts.BranchState.to_blob
+    |> store_blob tx
+
+  let ensure_default_branch tx root branch_index =
+    let open Utilities.Result in
+    let* current = Branch_index.find_branch tx BranchIndex.default_branch_name branch_index in
+    match current with
+    | Some _ -> Ok root
+    | None ->
+        (* Older initialization slices could leave a valid but empty branch
+           index. Repair it by publishing a new root containing master. *)
+        let* branch_state = create_initial_branch_state tx in
+        let* branch_index =
+          Branch_index.put_branch tx BranchIndex.default_branch_name branch_state branch_index
+        in
+        Ok (Branch_index.hash_of branch_index)
+
+  let create_in_transaction tx =
+    let open Utilities.Result in
+    let* branch_state = create_initial_branch_state tx in
+    let* branch_index =
+      Branch_index.put_branch tx BranchIndex.default_branch_name branch_state Branch_index.empty
+    in
+    let root = Branch_index.hash_of branch_index in
+    let* () = store_fixed_root tx root in
+    Ok root
+
+  let read connection = with_transaction connection read_in_transaction
+
+  let initialize connection =
+    with_transaction connection (fun tx ->
+        let open Utilities.Result in
+        let* current = read_in_transaction tx in
+        match current with
+        | None -> create_in_transaction tx
+        | Some root ->
+            let* branch_index = Branch_index.find tx root in
+            begin match branch_index with
+            | None -> Error (Error.missing_branch_index root)
+            | Some branch_index ->
+                let* root' = ensure_default_branch tx root branch_index in
+                let* () =
+                  if Concepts.Hash.hash_equals root root' then Ok () else store_fixed_root tx root'
+                in
+                Ok root'
+            end )
+end
diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli
new file mode 100644
index 0000000..4f98215
--- /dev/null
+++ b/lib/kernel/Initialization.mli
@@ -0,0 +1,10 @@
+type address = Concepts.Hash.hash
+type branch_index_root = address
+
+val fixed_label : string
+val fixed_label_address : address
+
+module Make (Store : Abstract.Storage.STORAGE) : sig
+  val read : Store.connection -> (branch_index_root option, Concepts.Condition.condition) result
+  val initialize : Store.connection -> (branch_index_root, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 82fdae0..5bd427f 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -22,6 +22,8 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
 
   val hash_of : node -> address
 
+  val persist : S.transaction -> node -> (address, Concepts.Condition.condition) result
+
   val insert : S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result
   val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
   val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result