diff options
| -rw-r--r-- | lib/kernel/BranchManager.ml | 63 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.mli | 8 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 126 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 11 | ||||
| -rw-r--r-- | lib/kernel/Merkle.ml | 4 |
5 files changed, 50 insertions, 162 deletions
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 03a2765..a698a87 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -9,8 +9,8 @@ module Error = struct condition "no-such-branch" "A branch with the specified name was not found" ("branch" |=| Concepts.Value.String branch_name) - let comparison_failed branch_name reference head = - condition "comparison-failed" "The HEAD of the branch did not match what was expected" + let branch_head_mismatch branch_name reference head = + condition "branch-head-mismatch" "The HEAD of the branch did not match what was expected" ("branch" |=| Concepts.Value.String branch_name & "reference" |=| Concepts.Value.String (Concepts.Hash.to_hum_string reference) & "head" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) @@ -20,17 +20,45 @@ module Make (S : Abstract.Storage.STORAGE) = struct module M = Merkle.Make (S) (Merkle.StringKey) module SI = Storage.Make (S) - type manager = { storage: S.connection; - label : string; - head: M.node Atomic.t } - 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 initialize storage label = + class manager storage label head = object (self) + inherit Lifecycle.null + + val storage : S.connection = storage + val label : string = label + val head : M.node Atomic.t = Atomic.make head + + method fetch branch_name = + SI.with_transaction storage (fun tx -> + let head = Atomic.get head in + M.lookup tx branch_name head) + + method update branch_name reference new_branch = + let open Utilities.Result in + SI.with_transaction storage (fun tx -> + Utilities.Atomic.mswap head (fun head -> + let* branch = M.lookup tx branch_name head + |> fmap (Option.to_result ~none:(Error.no_such_branch branch_name)) in + if branch = reference then + let* new_head = M.insert tx label new_branch head in + Ok new_head + else + Error (Error.branch_head_mismatch branch_name reference branch))) + |> Result.map ignore + + method protocols = Protocols.[Directory.make self] + + method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) + + method find _ = failwith "TODO" + end + + let make storage label = let open Utilities.Result in SI.with_transaction storage (fun tx -> let* addr = root_for tx label in @@ -39,25 +67,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct | Some addr -> let* head = M.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 = - SI.with_transaction storage (fun tx -> - let head = Atomic.get head in - M.lookup tx branch_name head) - - let update { storage; head; label } branch_name reference new_branch = - let open Utilities.Result in - let* _ = SI.with_transaction storage (fun tx -> - Utilities.Atomic.mswap head (fun head -> - let* branch = M.lookup tx branch_name head - |> Result.map (Option.to_result ~none:(Error.no_such_branch branch_name)) - |> Result.join in - if branch = reference then - let* new_head = M.insert tx label new_branch head in - Ok new_head - else - Error (Error.comparison_failed branch_name reference branch))) in - Ok () + Ok (new manager storage label head |> Protocols.Handle.make)) end diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli index 052f9a1..a75875f 100644 --- a/lib/kernel/BranchManager.mli +++ b/lib/kernel/BranchManager.mli @@ -1,9 +1,3 @@ module Make (S : Abstract.Storage.STORAGE) : sig - type manager - - val initialize : S.connection -> string -> (manager, Concepts.Condition.condition) result - val fetch : manager -> string -> (Concepts.Hash.hash option, Concepts.Condition.condition) result - val update : manager -> string -> Concepts.Hash.hash -> Concepts.Hash.hash -> (unit, Concepts.Condition.condition) result - - (* TODO: fork, join *) + val make : S.connection -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index 767dcca..3eb8aed 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -1,122 +1,12 @@ -type address = Concepts.Hash.hash -type branch_index_root = address +module Make (S : Abstract.Storage.STORAGE) = struct + module BM = BranchManager.Make (S) -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 initialize conn = 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 + let open Protocols in + let root = Namespace.make () in + let registry = Registry.from root |> Option.get in + let* branch = BM.make conn "rnt-head" in + let* () = Registry.register registry "branch" branch 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 index 4f98215..104d523 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,10 +1,3 @@ -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 +module Make (S : Abstract.Storage.STORAGE) : sig + val initialize : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index ababb03..6172e6f 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -30,6 +30,7 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result val fold_left : S.transaction -> ('c -> K.t -> address -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result + val keys : S.transaction -> node -> (K.t BatFingerTree.t, Concepts.Condition.condition) result end module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct @@ -120,7 +121,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct be used for intermediates and the like. *) let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob - let find tx addr = + let find tx node = let open Utilities.Result in let* data = S.get tx (S.Hash node) in match data with @@ -303,6 +304,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct fold_left tx f acc node) (Ok acc) children + let keys tx node = fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig |