diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/BranchManager.ml | 16 | ||||
| -rw-r--r-- | lib/kernel/Merkle.ml | 22 | ||||
| -rw-r--r-- | lib/kernel/Runtime.ml | 45 | ||||
| -rw-r--r-- | lib/kernel/Storage.mli | 2 |
4 files changed, 22 insertions, 63 deletions
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 80e32a4..03a2765 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -1,5 +1,3 @@ -type branch = string - module Error = struct open Concepts.Condition @@ -7,6 +5,10 @@ module Error = struct 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))) + let no_such_branch branch_name = + 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" ("branch" |=| Concepts.Value.String branch_name & @@ -44,16 +46,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct let head = Atomic.get head in M.lookup tx branch_name head) - let update ({ storage; head; label } as manager) branch_name reference new_branch = + 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 in + 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 - new_head + Ok new_head else - Error.comparison_failed branch_name reference branch)) in + Error (Error.comparison_failed branch_name reference branch))) in Ok () end diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 60a10a7..c2c2932 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -1,8 +1,8 @@ module type VALUE = sig type t - val encode : t -> Concepts.Representation.blob - val decode : Concepts.Representation.blob -> (t, Concepts.Condition.condition) result + val encode : t -> Concepts.Blob.t + val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result end module type KEY = sig @@ -65,12 +65,12 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct | Trunk { keys; _ } -> keys let of_bencode = - let open Concepts.Codec.Bencode in + let open Concepts.Encoding.Bencode in let open Utilities.Result in (* This is terrible *) let decode_key t = as_string t |> Result.map String.to_bytes - |> Result.map Concepts.Representation.blob_of_bytes + |> Result.map Concepts.Blob.blob_of_bytes |> fmap K.decode in let decode_value t = as_string t |> Result.map Concepts.Hash.of_raw_string in let decode_list f data = data @@ -89,14 +89,14 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct Ok (Trunk { keys; children }) | _ -> Error (Error.malformed_node ()) - let from_blob blob = Concepts.Codec.Bencode.of_blob blob + let from_blob blob = Concepts.Encoding.Bencode.of_blob blob |> Utilities.Result.fmap of_bencode let to_bencode = - let open Concepts.Codec.Bencode in + let open Concepts.Encoding.Bencode in (* Ditto. *) let bencode_key k = K.encode k - |> Concepts.Representation.bytes_of_blob + |> Concepts.Blob.bytes_of_blob |> String.of_bytes |> (fun s -> String s) in let bencode_hash h = String (Concepts.Hash.to_raw_string h) in @@ -108,7 +108,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct Tagged ('#', Dict [("keys", List (BatFingerTree.to_list keys |> List.map bencode_key)); ("children", List (BatFingerTree.to_list children |> List.map bencode_hash))]) - let to_blob node = to_bencode node |> Concepts.Codec.Bencode.to_blob + let to_blob node = to_bencode node |> Concepts.Encoding.Bencode.to_blob (* TODO: we should probably cache this inside the node itself rather than recalculating it every time. We could also allow the user to @@ -216,7 +216,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct BatFingerTree.iter (fun k -> K.encode k - |> Concepts.Representation.bytes_of_blob + |> Concepts.Blob.bytes_of_blob |> Buffer.add_bytes buffer) ks; Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) @@ -343,7 +343,7 @@ end module StringKey : KEY with type t = string = struct type t = string - let encode s = String.to_bytes s |> Concepts.Representation.blob_of_bytes + let encode s = String.to_bytes s |> Concepts.Blob.blob_of_bytes let compare s1 s2 = String.compare s1 s2 |> Concepts.Ordering.of_int - let decode b = Concepts.Representation.bytes_of_blob b |> String.of_bytes |> Result.ok + let decode b = Concepts.Blob.bytes_of_blob b |> String.of_bytes |> Result.ok end diff --git a/lib/kernel/Runtime.ml b/lib/kernel/Runtime.ml deleted file mode 100644 index aa69791..0000000 --- a/lib/kernel/Runtime.ml +++ /dev/null @@ -1,45 +0,0 @@ -module Error = struct - open Concepts.Condition - - let registry_conflict () = - condition "registry-object-update-conflict" "Failed to update the in-memory object registry" - empty -end - -module CAS : Backend.Managers.Object.RUNTIME_STRATEGY = struct - type 'a state = 'a Atomic.t - type 'a token = 'a - - let create = Atomic.make - - let acquire state = - let photograph = Atomic.get state in - photograph, photograph - - let publish state token next = - if Atomic.compare_and_set state token next then Ok () else Error (Error.registry_conflict ()) -end - -(* module MVCC : REGISTRY_STRATEGY = struct end *) -(* module RCU : REGISTRY_STRATEGY = struct end *) - -module Make (Strategy : Backend.Managers.Object.RUNTIME_STRATEGY) (Store : Abstract.Storage.STORAGE) = -struct - module Init = Initialization.Make (Store) - module Objects = Backend.Managers.Object.Make (Strategy) - - type t = {connection: Store.connection; objects: Objects.t} - - let initialize configuration : (t, Concepts.Condition.condition) result = - let open Utilities.Result in - let* connection = Store.connect configuration in - let* branch_index_root = Init.initialize connection in - (* Registry reconstruction from the branch index is the loader boundary. - Until that loader exists, publish only the permanent /system namespace; - importantly, the discovered root remains part of the photograph. *) - let objects = Objects.create ~branch_index_root ~registry:Backend.Managers.Object.root in - Ok {connection; objects} - - let connection runtime = runtime.connection - let objects runtime = runtime.objects -end diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli index 3ef1ffc..1148fba 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -1,5 +1,5 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result - val store_blob : S.transaction -> Concepts.Representation.blob -> (Concepts.Hash.hash, Concepts.Condition.condition) result + val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result end |