Initialization with Branch State and Index

5 files changed, 191 insertions, 0 deletions

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