diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/BranchIndex.ml | 29 | ||||
| -rw-r--r-- | lib/kernel/BranchIndex.mli | 28 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.ml | 46 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.mli | 4 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 101 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 9 |
6 files changed, 37 insertions, 180 deletions
diff --git a/lib/kernel/BranchIndex.ml b/lib/kernel/BranchIndex.ml deleted file mode 100644 index 00bd44d..0000000 --- a/lib/kernel/BranchIndex.ml +++ /dev/null @@ -1,29 +0,0 @@ -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 empty_under = Tree.empty_under - let hash_of = Tree.hash_of - 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 deleted file mode 100644 index ec7bfc7..0000000 --- a/lib/kernel/BranchIndex.mli +++ /dev/null @@ -1,28 +0,0 @@ -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 empty_under : Store.transaction -> (address, Concepts.Condition.condition) result - val hash_of : tree -> root - 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/BranchManager.ml b/lib/kernel/BranchManager.ml index 6884219..71a25b3 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -2,28 +2,52 @@ module BranchValue = Merkle.StringKey (* FIXME *) type branch = string +module Error = struct + open Concepts.Condition + + let invalid_root head = condition "invalid-root" "The root hash for the database state is missing from the backend. Either your storage is corrupted, or this is a bug in RNT!" + ("hash" |=| (Concepts.Value.String (Concepts.Hash.to_hum_string head))) +end + module Make (S : Abstract.Storage.STORAGE) = struct module I = Merkle.Interface (S) (Merkle.StringKey) (BranchValue) module SI = Storage.Make (S) - type manager = { storage: S.connection; head: I.node Atomic.t } + type manager = { storage: S.connection; + label : string; + head: I.node Atomic.t } - let initialize storage addr = + let root_for tx label = + let open Utilities.Result in + let* label = S.get tx (S.Label label) in + let label = Option.map Concepts.Hash.hash_of_blob label in + Ok label + + let persist_root tx label new_branch = failwith "TODO" + + let initialize storage label = let open Utilities.Result in SI.with_transaction storage (fun tx -> - let* head = I.find tx addr in - Ok { storage; head = Option.value head ~default:I.empty |> Atomic.make }) + let* addr = root_for tx label in + match addr with + | None -> failwith "TODO" + | Some addr -> + let* head = I.find tx addr in + let* head = Option.to_result ~none:(Error.invalid_root addr) head in + Ok { storage; label; head = Atomic.make head }) - let fetch { storage; head } branch_name = + let fetch { storage; head; _ } branch_name = SI.with_transaction storage (fun tx -> let head = Atomic.get head in I.lookup tx branch_name head) - let update ({ storage; head } as manager) branch_name f = + let update ({ storage; head; label } as manager) branch_name f = let open Utilities.Result in - SI.with_transaction storage (fun tx -> - let* new_head = Utilities.Atomic.mswap head (fun head -> - let* branch = I.lookup tx branch_name head in - f branch) in - Ok { manager with head = new_head }) + let* _ = SI.with_transaction storage (fun tx -> + Utilities.Atomic.mswap head (fun head -> + let* branch = I.lookup tx branch_name head in + let new_branch = f branch in + let* () = persist_root tx label new_branch in + new_branch)) in + Ok () end diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli index 1b572af..063f8a7 100644 --- a/lib/kernel/BranchManager.mli +++ b/lib/kernel/BranchManager.mli @@ -3,8 +3,8 @@ type branch = string (* FIXME *) module Make (S : Abstract.Storage.STORAGE) : sig type manager - val initialize : S.connection -> Concepts.Hash.hash -> (manager, Concepts.Condition.condition) result - val fetch : manager -> string -> (Concepts.Branch.t option, Concepts.Condition.condition) result + val initialize : S.connection -> string -> (manager, Concepts.Condition.condition) result + val fetch : manager -> string -> (branch option, Concepts.Condition.condition) result val update : manager -> string -> (branch -> branch) -> (manager, Concepts.Condition.condition) result (* TODO: fork, join *) diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml deleted file mode 100644 index fc7c51a..0000000 --- a/lib/kernel/Initialization.ml +++ /dev/null @@ -1,101 +0,0 @@ -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) - module S = Storage.Make (Store) - - let read_in_transaction tx = - let open Utilities.Result in - let* fixed = Store.get tx (Store.Hash 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_fixed_root tx root = Store.put tx (Store.Hash 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.empty_under tx in - Concepts.BranchState.make ~current:empty_root ~history:empty_root ~tip:None - |> Concepts.BranchState.to_blob - |> S.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 initialize connection = - S.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 deleted file mode 100644 index 5c348bd..0000000 --- a/lib/kernel/Initialization.mli +++ /dev/null @@ -1,9 +0,0 @@ -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 initialize : Store.connection -> (branch_index_root, Concepts.Condition.condition) result -end |