diff options
Diffstat (limited to 'lib/kernel')
| -rw-r--r-- | lib/kernel/BranchIndex.ml | 29 | ||||
| -rw-r--r-- | lib/kernel/BranchIndex.mli | 28 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.ml | 63 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.mli | 9 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.ml | 29 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.mli | 12 | ||||
| -rw-r--r-- | lib/kernel/Merkle.ml | 39 | ||||
| -rw-r--r-- | lib/kernel/Namespace.ml | 49 | ||||
| -rw-r--r-- | lib/kernel/Namespace.mli | 7 | ||||
| -rw-r--r-- | lib/kernel/Storage.ml | 22 | ||||
| -rw-r--r-- | lib/kernel/Storage.mli | 5 |
11 files changed, 221 insertions, 71 deletions
diff --git a/lib/kernel/BranchIndex.ml b/lib/kernel/BranchIndex.ml deleted file mode 100644 index d1efa9a..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 hash_of = Tree.hash_of - let persist = Tree.persist - 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 5a867bf..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 hash_of : tree -> root - val persist : Store.transaction -> tree -> (root, Concepts.Condition.condition) result - 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 new file mode 100644 index 0000000..03a2765 --- /dev/null +++ b/lib/kernel/BranchManager.ml @@ -0,0 +1,63 @@ +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))) + + 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 & + "reference" |=| Concepts.Value.String (Concepts.Hash.to_hum_string reference) & + "head" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) +end + +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 = + let open Utilities.Result in + SI.with_transaction storage (fun tx -> + let* addr = root_for tx label in + match addr with + | None -> failwith "TODO" + | 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 () + +end diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli new file mode 100644 index 0000000..052f9a1 --- /dev/null +++ b/lib/kernel/BranchManager.mli @@ -0,0 +1,9 @@ +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 *) +end diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml new file mode 100644 index 0000000..ff67ecf --- /dev/null +++ b/lib/kernel/Lifecycle.ml @@ -0,0 +1,29 @@ +class type lifecycle = object + method reference : bool + method release : unit +end + +class type virtual controlled_lifecycle = object + inherit lifecycle + method virtual destroy : unit +end + +class null = object + method reference = true + method release = () +end + +class virtual counted = object (self) + val references = Atomic.make 1 + + method virtual destroy : unit + + method reference = + Atomic.incr references; + true + + method release = + Atomic.decr references; + if Atomic.get references <= 0 then + self#destroy +end diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli new file mode 100644 index 0000000..f110768 --- /dev/null +++ b/lib/kernel/Lifecycle.mli @@ -0,0 +1,12 @@ +class type lifecycle = object + method reference : bool + method release : unit +end + +class type virtual controlled_lifecycle = object + inherit lifecycle + method virtual destroy : unit +end + +class null : lifecycle +class virtual counted : controlled_lifecycle diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index af703d7..ababb03 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 @@ -19,6 +19,7 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result val empty : node + val empty_under : S.transaction -> (address, Concepts.Condition.condition) result val hash_of : node -> address @@ -68,12 +69,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 @@ -92,14 +93,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 @@ -111,7 +112,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 @@ -121,7 +122,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let find tx addr = let open Utilities.Result in - let* data = S.get tx addr in + let* data = S.get tx (S.Hash node) in match data with | None -> Ok None | Some data -> @@ -149,9 +150,11 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let open Utilities.Result in let data = to_blob node in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr + let empty_under tx = persist tx empty + type op = Update of address * node | Split of address * K.t * address let emplace i v ft = @@ -217,7 +220,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) @@ -303,7 +306,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig - type address + type address = Concepts.Hash.hash type node val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result @@ -332,11 +335,11 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) let intern tx v = let data = V.encode v in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr let retrieve tx addr = - let* data = S.get tx addr in + let* data = S.get tx (S.Hash addr) in match data with | None -> Ok None | Some data -> @@ -379,3 +382,11 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (fun _ k v -> f k v |> ignore) () node end + +module StringKey : KEY with type t = string = struct + type t = string + + 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.Blob.bytes_of_blob b |> String.of_bytes |> Result.ok +end diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml new file mode 100644 index 0000000..7c9cd2b --- /dev/null +++ b/lib/kernel/Namespace.ml @@ -0,0 +1,49 @@ +module Errors = struct + include Concepts.Condition + + let key_already_exists key = + condition "key-already-exists" "The specified key already exists in the namespace" + ("key" |=| Concepts.Value.String key) + + let no_such_key key = + condition "no-such-key" "The specified key does not exist in the namespace" + ("key" |=| Concepts.Value.String key) +end + +class namespace = object (self) + inherit Lifecycle.null + + val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = + Atomic.make BatMap.empty + + method protocols = Protocols.[Directory.make self; Registry.make self] + + method register key value = + Utilities.Atomic.mswap entries + (fun e -> + match BatMap.find_opt key e with + | None -> Ok (BatMap.add key value e) + | Some _ -> Error (Errors.key_already_exists key)) + |> Result.map ignore + + method unregister key = + Utilities.Atomic.mswap entries + (fun e -> + try + Ok (BatMap.remove_exn key e) + with Not_found -> + Error (Errors.no_such_key key)) + |> Result.map ignore + + method list = + Atomic.get entries + |> BatMap.keys + |> BatList.of_enum + + method find key = + Atomic.get entries + |> BatMap.find_opt key + |> Utilities.Option.fmap Protocols.Handle.copy +end + +let make () = new namespace diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli new file mode 100644 index 0000000..3ed64a3 --- /dev/null +++ b/lib/kernel/Namespace.mli @@ -0,0 +1,7 @@ +class namespace : object + inherit Protocols.Handle.obj + inherit Protocols.Directory.implementation + inherit Protocols.Registry.implementation +end + +val make : unit -> namespace diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml new file mode 100644 index 0000000..376d839 --- /dev/null +++ b/lib/kernel/Storage.ml @@ -0,0 +1,22 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + let finish tx = function + | Ok value -> + let open Utilities.Result in + let* () = S.commit tx in + Ok value + | Error condition -> + let _ = S.abort tx in + Error condition + + let with_transaction connection body = + let open Utilities.Result in + let* tx = S.start connection in + body tx |> finish tx + + let store_blob tx blob = + let open Utilities.Result in + let address = Concepts.Hash.hash_of_blob blob in + let* () = S.put tx (S.Hash address) blob in + Ok address + +end diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli new file mode 100644 index 0000000..1148fba --- /dev/null +++ b/lib/kernel/Storage.mli @@ -0,0 +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.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result +end |