diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/BranchManager.ml | 143 |
1 files changed, 73 insertions, 70 deletions
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index bda4233..3531748 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -2,8 +2,10 @@ 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))) + 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 @@ -14,89 +16,90 @@ module Make (S : Abstract.Storage.STORAGE) = struct let root_for tx label = let open Utilities.Result in let* label = S.get tx (S.Label label) in - let data = Option.map (fun blob -> Concepts.Blob.bytes_of_blob blob - |> Bytes.to_string - |> Concepts.Hash.of_raw_string) - label in + let data = + Option.map + (fun blob -> + Concepts.Blob.bytes_of_blob blob |> Bytes.to_string |> Concepts.Hash.of_raw_string ) + label + in Ok data let persist_root tx label addr = let data = Concepts.Hash.blob_of_hash addr in S.put tx (S.Label label) data - class manager storage label head = object (self) - inherit Lifecycle.null - inherit Identity.of_id + class manager storage label head = + object (self) + inherit Lifecycle.null + inherit Identity.of_id + method to_string = "branch-manager" + val storage : S.connection = storage + val label : string = label + val head : M.node Atomic.t = Atomic.make head - method to_string = "branch-manager" + method fetch branch_name = + SI.with_transaction storage (fun tx -> + let head = Atomic.get head in + M.lookup tx branch_name head ) - val storage : S.connection = storage - val label : string = label - val head : M.node Atomic.t = Atomic.make head + method protocols = Protocols.[Directory.make self; Registry.make self] + method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) - method fetch branch_name = - SI.with_transaction storage (fun tx -> - let head = Atomic.get head in - M.lookup tx branch_name head) + method find key = + let open Utilities.Result in + SI.with_transaction storage (fun tx -> + let* head = Atomic.get head |> M.lookup tx key in + match head with + | None -> Ok None + | Some head -> B.load tx storage head |> Result.map Option.some ) - method protocols = Protocols.[Directory.make self; Registry.make self] - - method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) - - method find key = - let open Utilities.Result in - SI.with_transaction storage (fun tx -> - let* head = Atomic.get head |> M.lookup tx key in - match head with - | None -> Ok None - | Some head -> B.load tx storage head |> Result.map Option.some) - - method update key reference value = - let open Utilities.Result in - let open Protocols in - SI.with_transaction storage (fun tx -> - match - Utilities.Atomic.mswap head (fun head -> - let address_of h = - let* i = Handle.require Addressable.from h in - Ok (Addressable.address i) - in - let* branch = M.lookup tx key head |> Result.map_error (fun e -> Some e) in - let* reference = Option.map address_of reference - |> Utilities.Option.sequence - |> Result.map_error (fun e -> Some e) in - let* value = Option.map address_of value - |> Utilities.Option.sequence - |> Result.map_error (fun e -> Some e) in - if branch = reference then - begin - let* new_head = match value with - | Some value -> M.insert tx key value head - | None -> M.remove tx key head - in - let* _ = persist_root tx label (M.hash_of new_head) in - Ok new_head - end - |> Result.map_error (fun e -> Some e) - else - Error None) - with - | Ok _ -> Ok true - | Error None -> Ok false - | Error (Some e) -> Error e) - - end + method update key reference value = + let open Utilities.Result in + let open Protocols in + SI.with_transaction storage (fun tx -> + match + Utilities.Atomic.mswap head (fun head -> + let address_of h = + let* i = Handle.require Addressable.from h in + Ok (Addressable.address i) + in + let* branch = M.lookup tx key head |> Result.map_error (fun e -> Some e) in + let* reference = + Option.map address_of reference + |> Utilities.Option.sequence + |> Result.map_error (fun e -> Some e) + in + let* value = + Option.map address_of value + |> Utilities.Option.sequence + |> Result.map_error (fun e -> Some e) + in + if branch = reference then + begin + let* new_head = + match value with + | Some value -> M.insert tx key value head + | None -> M.remove tx key head + in + let* _ = persist_root tx label (M.hash_of new_head) in + Ok new_head + end + |> Result.map_error (fun e -> Some e) + else Error None ) + with + | Ok _ -> Ok true + | Error None -> Ok false + | Error (Some e) -> Error e ) + end let make storage label = let open Utilities.Result in SI.with_transaction storage (fun tx -> let* addr = root_for tx label in match addr with - | None -> - Ok (new manager storage label M.empty |> Protocols.Handle.make) + | None -> Ok (new manager storage label M.empty |> Protocols.Handle.make) | Some addr -> - let* head = M.find tx addr in - let* head = Option.to_result ~none:(Error.invalid_root addr) head in - Ok (new manager storage label head |> Protocols.Handle.make)) - + let* head = M.find tx addr in + let* head = Option.to_result ~none:(Error.invalid_root addr) head in + Ok (new manager storage label head |> Protocols.Handle.make) ) end |