initialization

2 files changed, 119 insertions, 0 deletions

diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml
new file mode 100644
index 0000000..d15b65b
--- /dev/null
+++ b/lib/kernel/Initialization.ml
@@ -0,0 +1,100 @@
+type address = Concepts.Hash.hash
+
+type t =
+  { default_branch: string;
+    branches: address }
+
+let fixed_label = "rnt.boot"
+let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label)
+
+module Field = struct
+  let default_branch = "default_branch"
+  let branches = "branches"
+end
+
+module Error = struct
+  open Concepts.Condition
+
+  let malformed_initialization () =
+    condition "initialization-malformed"
+      "An initialization representation did not conform to what was expected" empty
+
+  let malformed_hash length =
+    condition "initialization-malformed-hash"
+      "An initialization address was not a valid hash"
+      ("length" |=| Concepts.Value.Integer length)
+
+  let missing_target address =
+    condition "initialization-target-missing"
+      "The fixed initialization label points at a missing object"
+      ("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address))
+end
+
+let make ~default_branch ~branches = {default_branch; branches}
+
+let default_branch initialization = initialization.default_branch
+let branches initialization = initialization.branches
+
+module Body = struct
+  type nonrec t = t
+
+  let tag = 'i'
+  let malformed = Error.malformed_initialization
+
+  let equal left right =
+    String.equal left.default_branch right.default_branch
+    && Concepts.Hash.hash_equals left.branches right.branches
+
+  let fields initialization =
+    [ Field.default_branch, Concepts.Object.Field.string initialization.default_branch;
+      Field.branches, Concepts.Object.Field.address initialization.branches ]
+
+  let of_fields data =
+    let open Utilities.Result in
+    let* default_branch =
+      Concepts.Object.Field.require_string Field.default_branch data
+    in
+    let* branches =
+      Concepts.Object.Field.require_address ~malformed:Error.malformed_hash Field.branches data
+    in
+    Ok {default_branch; branches}
+end
+
+include (Concepts.Object.Codec.Make (Body) : Concepts.Object.S with type t := t)
+
+let address initialization = to_blob initialization |> Concepts.Hash.hash_of_blob
+
+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_hash (String.length raw))
+
+module Make (Store : Abstract.Storage.STORAGE) = struct
+  let register tx initialization =
+    let open Utilities.Result in
+    let blob = to_blob initialization in
+    let initialization_address = Concepts.Hash.hash_of_blob blob in
+    let* () = Store.put tx initialization_address blob in
+    let* () = Store.put tx fixed_label_address (address_to_blob initialization_address) in
+    Ok initialization_address
+
+  let load tx =
+    let open Utilities.Result in
+    let* label = Store.get tx fixed_label_address in
+    match label with
+    | None -> Ok None
+    | Some label ->
+        let* initialization_address = address_of_blob label in
+        let* initialization = Store.get tx initialization_address in
+        begin match initialization with
+        | None -> Error (Error.missing_target initialization_address)
+        | Some initialization ->
+            let* initialization = of_blob initialization in
+            Ok (Some initialization)
+        end
+end
diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli
new file mode 100644
index 0000000..35e6f22
--- /dev/null
+++ b/lib/kernel/Initialization.mli
@@ -0,0 +1,19 @@
+type address = Concepts.Hash.hash
+
+type t
+
+val fixed_label : string
+val fixed_label_address : address
+
+include Concepts.Object.S with type t := t
+
+val make : default_branch:string -> branches:address -> t
+
+val default_branch : t -> string
+val branches : t -> address
+val address : t -> address
+
+module Make (Store : Abstract.Storage.STORAGE) : sig
+  val register : Store.transaction -> t -> (address, Concepts.Condition.condition) result
+  val load : Store.transaction -> (t option, Concepts.Condition.condition) result
+end