Initialization with Branch State and Index

2 files changed, 104 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