From 8d59f43f445164e8cc8bd3fe1a23bd04e807a6b3 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sun, 2 Aug 2026 23:37:51 -0300 Subject: format --- lib/Utilities.ml | 14 +- lib/backend/managers/Lifecycle.ml | 3 +- lib/concepts/Branch.ml | 13 +- lib/concepts/Branch.mli | 1 - lib/concepts/Codec.ml | 102 +++---- lib/concepts/Hash.ml | 10 +- lib/concepts/Multigroup.ml | 10 +- lib/concepts/Multigroup.mli | 1 - lib/concepts/Object.ml | 7 +- lib/concepts/Object.mli | 4 - lib/concepts/Ordering.ml | 3 +- lib/concepts/Relation.ml | 18 +- lib/concepts/Relation.mli | 2 - lib/kernel/Merkle.ml | 568 +++++++++++++++++++------------------- test/Helpers.ml | 12 +- test/test_rnt.ml | 2 + test/unit/backend/Storage.ml | 4 +- test/unit/kernel/Merkle.ml | 23 +- 18 files changed, 371 insertions(+), 426 deletions(-) diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 9ae0119..f2c96a7 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -2,11 +2,11 @@ module Result = struct let ( let* ) = Result.bind let fmap f m = Result.bind m f - let sequence ms = List.fold_right - (fun m acc -> - let* acc = acc in - let* m = m in - Ok (m::acc)) - ms - (Ok []) + let sequence ms = + List.fold_right + (fun m acc -> + let* acc = acc in + let* m = m in + Ok (m :: acc) ) + ms (Ok []) end diff --git a/lib/backend/managers/Lifecycle.ml b/lib/backend/managers/Lifecycle.ml index d104249..5f336ef 100644 --- a/lib/backend/managers/Lifecycle.ml +++ b/lib/backend/managers/Lifecycle.ml @@ -79,7 +79,8 @@ let rec cascade (tree : tree) (disposals : disposal BatFingerTree.t) (path : Con in Result.bind (Object.unregister path tree) (fun tree -> BatFingerTree.fold_left - (fun acc dep -> Result.bind acc (fun (tree, disposals) -> cascade tree disposals dep)) + (fun acc dep -> + Result.bind acc (fun (tree, disposals) -> cascade tree disposals dep) ) (Ok (tree, disposals)) edges ) end diff --git a/lib/concepts/Branch.ml b/lib/concepts/Branch.ml index cd4213b..57c46b3 100644 --- a/lib/concepts/Branch.ml +++ b/lib/concepts/Branch.ml @@ -1,8 +1,5 @@ type address = Hash.hash - -type t = - { name: string; - target: address } +type t = {name: string; target: address} module Field = struct let name = "name" @@ -22,7 +19,6 @@ module Error = struct end let make ~name ~target = {name; target} - let name branch = branch.name let target branch = branch.target @@ -31,13 +27,10 @@ module Body = struct let tag = 'b' let malformed = Error.malformed_branch - - let equal left right = - left.name = right.name && Hash.hash_equals left.target right.target + let equal left right = left.name = right.name && Hash.hash_equals left.target right.target let fields branch = - [ Field.name, Object.Field.string branch.name; - Field.target, Object.Field.address branch.target ] + [Field.name, Object.Field.string branch.name; Field.target, Object.Field.address branch.target] let of_fields data = let open Utilities.Result in diff --git a/lib/concepts/Branch.mli b/lib/concepts/Branch.mli index 0e7e9f9..3fb6ebe 100644 --- a/lib/concepts/Branch.mli +++ b/lib/concepts/Branch.mli @@ -4,6 +4,5 @@ type address = Hash.hash include Object.S with type t := t val make : name:string -> target:address -> t - val name : t -> string val target : t -> address diff --git a/lib/concepts/Codec.ml b/lib/concepts/Codec.ml index 758d718..97039c3 100644 --- a/lib/concepts/Codec.ml +++ b/lib/concepts/Codec.ml @@ -1,4 +1,4 @@ - module Error = struct +module Error = struct open Condition let unexpected_end = @@ -16,21 +16,19 @@ condition "codec-string-out-of-bounds" "A string length runs past the end of input" ("length" |=| Value.Integer length) - let trailing_bytes = - condition "codec-trailing-bytes" "Bytes remain after a complete value" empty + let trailing_bytes = condition "codec-trailing-bytes" "Bytes remain after a complete value" empty let tag_mismatch ~expected ~actual = condition "codec-tag-mismatch" "A value with a different tag was expected" - ("expected" |=| Value.String (String.make 1 expected) & - "actual" |=| Value.String (String.make 1 actual)) + ( "expected" |=| Value.String (String.make 1 expected) + & "actual" |=| Value.String (String.make 1 actual) ) let type_mismatch ~expected = condition "codec-type-mismatch" "A Bencode value of a different shape was expected" ("expected" |=| Value.String expected) let missing_field key = - condition "codec-missing-field" "A required field is absent" - ("field" |=| Value.String key) + condition "codec-missing-field" "A required field is absent" ("field" |=| Value.String key) let unexpected_object ~expected ~actual = condition "codec-unexpected-object" "The decoded object is not of the expected kind" @@ -49,38 +47,37 @@ end - List "l" * "e" - Dict "d" ( )* "e" keys sorted on encode *) module Bencode = struct - type t = Tagged of char * t | Int of int | String of string | List of t list | Dict of (string * t) list + type t = + | Tagged of char * t + | Int of int + | String of string + | List of t list + | Dict of (string * t) list let rec encode buf = function - | Tagged (tag, value) -> - Buffer.add_char buf 't'; - Buffer.add_char buf tag; - encode buf value + | Tagged (tag, value) -> Buffer.add_char buf 't'; Buffer.add_char buf tag; encode buf value | Int n -> - Buffer.add_char buf 'i'; - Buffer.add_string buf (string_of_int n); - Buffer.add_char buf 'e' + Buffer.add_char buf 'i'; + Buffer.add_string buf (string_of_int n); + Buffer.add_char buf 'e' | String s -> - Buffer.add_string buf (string_of_int (String.length s)); - Buffer.add_char buf ':'; - Buffer.add_string buf s + Buffer.add_string buf (string_of_int (String.length s)); + Buffer.add_char buf ':'; + Buffer.add_string buf s | List xs -> - Buffer.add_char buf 'l'; - List.iter (encode buf) xs; - Buffer.add_char buf 'e' + Buffer.add_char buf 'l'; + List.iter (encode buf) xs; + Buffer.add_char buf 'e' | Dict kvs -> - Buffer.add_char buf 'd'; - List.iter - (fun (k, v) -> - encode buf (String k); - encode buf v ) - (List.sort (fun (a, _) (b, _) -> String.compare a b) kvs); - Buffer.add_char buf 'e' + Buffer.add_char buf 'd'; + List.iter + (fun (k, v) -> encode buf (String k); encode buf v) + (List.sort (fun (a, _) (b, _) -> String.compare a b) kvs); + Buffer.add_char buf 'e' let to_bytes (value : t) : bytes = let buf = Buffer.create 256 in - encode buf value; - Buffer.to_bytes buf + encode buf value; Buffer.to_bytes buf let as_string = function String s -> Ok s | _ -> Error (Error.type_mismatch ~expected:"string") let as_int = function Int n -> Ok n | _ -> Error (Error.type_mismatch ~expected:"integer") @@ -92,7 +89,7 @@ module Bencode = struct let s = Bytes.to_string bytes in let n = String.length s in let pos = ref 0 in - let peek () = if !pos >= n then Error (Error.unexpected_end) else Ok (s.[!pos]) in + let peek () = if !pos >= n then Error Error.unexpected_end else Ok s.[!pos] in let advance () = incr pos in (* Read the decimal run up to (and consuming) [term]. *) let read_int_from start term = @@ -106,8 +103,7 @@ module Bencode = struct | None -> Error (Error.malformed_integer digits) end else begin - advance (); - scan () + advance (); scan () end in scan () @@ -115,43 +111,44 @@ module Bencode = struct let read_int term = read_int_from !pos term in let read_char () = let* c = peek () in - advance (); - Ok c + advance (); Ok c in let rec parse () = let* c = peek () in advance (); match c with | 't' -> - let* tag = read_char () in - let* data = parse () in - Ok (Tagged (tag, data)) + let* tag = read_char () in + let* data = parse () in + Ok (Tagged (tag, data)) | 'i' -> - let* n = read_int 'e' in - Ok (Int n) + let* n = read_int 'e' in + Ok (Int n) | 'l' -> parse_list [] | 'd' -> parse_dict [] | c when c >= '0' && c <= '9' -> parse_string_from (!pos - 1) | c -> Error (Error.unexpected_byte c) - and parse_string () = - parse_string_from !pos + and parse_string () = parse_string_from !pos and parse_string_from start = let* len = read_int_from start ':' in - if len < 0 || !pos + len > n then - Error (Error.string_out_of_bounds len) + if len < 0 || !pos + len > n then Error (Error.string_out_of_bounds len) else let str = String.sub s !pos len in pos := !pos + len; Ok (String str) and parse_list acc = let* c = peek () in - if c = 'e' then (advance (); Ok (List (List.rev acc))) + if c = 'e' then ( + advance (); + Ok (List (List.rev acc)) ) else let* result = parse () in parse_list (result :: acc) and parse_dict acc = let* c = peek () in - if c = 'e' then (advance (); Ok (Dict (List.rev acc))) + if c = 'e' then ( + advance (); + Ok (Dict (List.rev acc)) ) else let* key = parse_string () in let* key = as_string key in @@ -159,24 +156,17 @@ module Bencode = struct parse_dict ((key, value) :: acc) in let* value = parse () in - if !pos <> n then Error Error.trailing_bytes else - Ok value + if !pos <> n then Error Error.trailing_bytes else Ok value let to_blob x = to_bytes x |> Representation.blob_of_bytes let of_blob b = Representation.bytes_of_blob b |> of_bytes let with_tag t = function - | Tagged (t', v) -> - if t = t' then - Ok v - else - Error (Error.tag_mismatch ~expected:t ~actual:t') + | Tagged (t', v) -> if t = t' then Ok v else Error (Error.tag_mismatch ~expected:t ~actual:t') | _ -> Error (Error.type_mismatch ~expected:"tagged") let field key = function | Dict kvs -> ( - match List.assoc_opt key kvs with - | Some v -> Ok v - | None -> Error (Error.missing_field key) ) + match List.assoc_opt key kvs with Some v -> Ok v | None -> Error (Error.missing_field key) ) | _ -> Error (Error.type_mismatch ~expected:"dict") end diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml index aac7428..a84c60d 100644 --- a/lib/concepts/Hash.ml +++ b/lib/concepts/Hash.ml @@ -2,22 +2,16 @@ type hash = Digestif.SHA256.t -let size = 256/8 - -let compare h1 h2 = Digestif.SHA256.unsafe_compare h1 h2 - |> Ordering.of_int +let size = 256 / 8 +let compare h1 h2 = Digestif.SHA256.unsafe_compare h1 h2 |> Ordering.of_int let hash_of_value (v : Value.value) = Representation.(blob_of_value v |> bytes_of_blob) |> Digestif.SHA256.digest_bytes let hash_of_bytes bytes = Digestif.SHA256.digest_bytes bytes - let hash_of_blob blob = Representation.bytes_of_blob blob |> Digestif.SHA256.digest_bytes - let to_raw_string hash = Digestif.SHA256.to_raw_string hash - let of_raw_string str = Digestif.SHA256.of_raw_string str - let hash_equals = Digestif.SHA256.equal let bytes_of_hash (h : hash) = Bytes.of_string (Digestif.SHA256.to_raw_string h) diff --git a/lib/concepts/Multigroup.ml b/lib/concepts/Multigroup.ml index 863cd26..b8fc743 100644 --- a/lib/concepts/Multigroup.ml +++ b/lib/concepts/Multigroup.ml @@ -1,8 +1,5 @@ type address = Hash.hash - -type t = - { name: string; - relations: address } +type t = {name: string; relations: address} module Field = struct let name = "name" @@ -22,7 +19,6 @@ module Error = struct end let make ~name ~relations = {name; relations} - let name multigroup = multigroup.name let relations multigroup = multigroup.relations @@ -31,9 +27,7 @@ module Body = struct let tag = 'm' let malformed = Error.malformed_multigroup - - let equal left right = - left.name = right.name && Hash.hash_equals left.relations right.relations + let equal left right = left.name = right.name && Hash.hash_equals left.relations right.relations let fields multigroup = [ Field.name, Object.Field.string multigroup.name; diff --git a/lib/concepts/Multigroup.mli b/lib/concepts/Multigroup.mli index 1a76dce..ef0f8ea 100644 --- a/lib/concepts/Multigroup.mli +++ b/lib/concepts/Multigroup.mli @@ -4,6 +4,5 @@ type address = Hash.hash include Object.S with type t := t val make : name:string -> relations:address -> t - val name : t -> string val relations : t -> address diff --git a/lib/concepts/Object.ml b/lib/concepts/Object.ml index 22fb14a..aacbda6 100644 --- a/lib/concepts/Object.ml +++ b/lib/concepts/Object.ml @@ -6,13 +6,10 @@ module type S = sig type t val equal : t -> t -> bool - val to_bencode : t -> bencode val of_bencode : bencode -> (t, Condition.condition) result - val to_blob : t -> Representation.blob val of_blob : Representation.blob -> (t, Condition.condition) result - val to_bytes : t -> bytes val of_bytes : bytes -> (t, Condition.condition) result end @@ -51,13 +48,11 @@ module Codec = struct let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_)) let of_bencode = function - | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> - B.of_fields data + | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> B.of_fields data | _ -> Error (B.malformed ()) let to_blob object_ = to_bencode object_ |> Bencode.to_blob let of_blob blob = Bencode.of_blob blob |> Utilities.Result.fmap of_bencode - let to_bytes object_ = to_blob object_ |> Representation.bytes_of_blob let of_bytes bytes = Bencode.of_bytes bytes |> Utilities.Result.fmap of_bencode end diff --git a/lib/concepts/Object.mli b/lib/concepts/Object.mli index e132673..7b0c4fd 100644 --- a/lib/concepts/Object.mli +++ b/lib/concepts/Object.mli @@ -4,13 +4,10 @@ module type S = sig type t val equal : t -> t -> bool - val to_bencode : t -> bencode val of_bencode : bencode -> (t, Condition.condition) result - val to_blob : t -> Representation.blob val of_blob : Representation.blob -> (t, Condition.condition) result - val to_bytes : t -> bytes val of_bytes : bytes -> (t, Condition.condition) result end @@ -20,7 +17,6 @@ module type OBJECT = S module Field : sig val string : string -> bencode val address : Hash.hash -> bencode - val require_string : string -> bencode -> (string, Condition.condition) result val require_address : diff --git a/lib/concepts/Ordering.ml b/lib/concepts/Ordering.ml index 42b20e5..8952b41 100644 --- a/lib/concepts/Ordering.ml +++ b/lib/concepts/Ordering.ml @@ -1,4 +1,3 @@ type ordering = Equal | Smaller | Greater -let of_int x = - if x < 0 then Smaller else if x > 0 then Greater else Equal +let of_int x = if x < 0 then Smaller else if x > 0 then Greater else Equal diff --git a/lib/concepts/Relation.ml b/lib/concepts/Relation.ml index a4fb341..1194804 100644 --- a/lib/concepts/Relation.ml +++ b/lib/concepts/Relation.ml @@ -1,10 +1,6 @@ type address = Hash.hash type schema = string BatMap.String.t - -type t = - { name: string; - tuples: address; - schema: schema } +type t = {name: string; tuples: address; schema: schema} module Field = struct let name = "name" @@ -25,31 +21,27 @@ module Error = struct end let make ~name ~tuples ~schema = {name; tuples; schema} - let name relation = relation.name let tuples relation = relation.tuples let schema relation = relation.schema - let schema_empty = BatMap.String.empty let schema_of_list fields = - List.fold_left (fun acc (name, domain) -> BatMap.String.add name domain acc) schema_empty - fields + List.fold_left (fun acc (name, domain) -> BatMap.String.add name domain acc) schema_empty fields let schema_to_list schema = BatMap.String.bindings schema let schema_to_bencode schema = Codec.Bencode.Dict - (schema_to_list schema - |> List.map (fun (name, domain) -> name, Codec.Bencode.String domain) ) + (schema_to_list schema |> List.map (fun (name, domain) -> name, Codec.Bencode.String domain)) let schema_of_bencode value = let open Utilities.Result in let* fields = Codec.Bencode.as_dict value in fields |> List.map (fun (name, domain) -> - let* domain = Codec.Bencode.as_string domain in - Ok (name, domain) ) + let* domain = Codec.Bencode.as_string domain in + Ok (name, domain) ) |> sequence |> Result.map schema_of_list diff --git a/lib/concepts/Relation.mli b/lib/concepts/Relation.mli index 5319a3d..d370578 100644 --- a/lib/concepts/Relation.mli +++ b/lib/concepts/Relation.mli @@ -5,11 +5,9 @@ type schema include Object.S with type t := t val make : name:string -> tuples:address -> schema:schema -> t - val name : t -> string val tuples : t -> address val schema : t -> schema - val schema_empty : schema val schema_of_list : (string * string) list -> schema val schema_to_list : schema -> (string * string) list diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 5bd427f..913c9f1 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -13,191 +13,188 @@ end module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig type address = Concepts.Hash.hash - type node val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result - val empty : node - val hash_of : node -> address - val persist : S.transaction -> node -> (address, Concepts.Condition.condition) result - val insert : S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result + val insert : + S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result + val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result end -module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct - type address = Concepts.Hash.hash - - module Error = struct - open Concepts.Condition - - let malformed_node () = condition "malformed-node" "A node representation did not conform to what was expected" empty - end - - type node = - Leaf of - { keys : K.t BatFingerTree.t; - values : address BatFingerTree.t } - | Trunk of - { keys : K.t BatFingerTree.t; - children : address BatFingerTree.t } - - let empty = Leaf { keys = BatFingerTree.empty; values = BatFingerTree.empty } - - let rec lookup1' keys key bottom top = - let open Concepts.Ordering in - if bottom >= top then (bottom, false) - else - let mid = bottom + (top - bottom) / 2 in - let node = BatFingerTree.get keys mid in - match K.compare node key with - | Equal -> (mid, true) - | Greater -> lookup1' keys key bottom mid - | Smaller -> lookup1' keys key (mid + 1) top - - let lookup1 keys key = lookup1' keys key 0 (BatFingerTree.size keys) - - let keys_of = function - | Leaf { keys; _ } -> keys - | Trunk { keys; _ } -> keys - - let of_bencode = - let open Concepts.Codec.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 - |> 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 - |> fmap as_list - |> Result.map (List.map f) - |> fmap sequence - |> Result.map BatFingerTree.of_list in - function - | Tagged ('!', (Dict _ as data)) -> - let* keys = field "keys" data |> decode_list decode_key in - let* values = field "values" data |> decode_list decode_value in - Ok (Leaf { keys; values }) - | Tagged ('#', (Dict _ as data)) -> - let* keys = field "keys" data |> decode_list decode_key in - let* children = field "children" data |> decode_list decode_value in - Ok (Trunk { keys; children }) - | _ -> Error (Error.malformed_node ()) - - let from_blob blob = Concepts.Codec.Bencode.of_blob blob - |> Utilities.Result.fmap of_bencode - - let to_bencode = - let open Concepts.Codec.Bencode in - (* Ditto. *) - let bencode_key k = K.encode k - |> Concepts.Representation.bytes_of_blob - |> String.of_bytes - |> (fun s -> String s) in - let bencode_hash h = String (Concepts.Hash.to_raw_string h) in - function - | Leaf { keys; values } -> - Tagged ('!', Dict [("keys", List (BatFingerTree.to_list keys |> List.map bencode_key)); - ("values", List (BatFingerTree.to_list values |> List.map bencode_hash))]) - | Trunk { keys; children } -> - 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 - - (* TODO: we should probably cache this inside the node itself rather +module Make : TREE = +functor + (S : Abstract.Storage.STORAGE) + (K : KEY) + -> + struct + type address = Concepts.Hash.hash + + module Error = struct + open Concepts.Condition + + let malformed_node () = + condition "malformed-node" "A node representation did not conform to what was expected" + empty + end + + type node = + | Leaf of {keys: K.t BatFingerTree.t; values: address BatFingerTree.t} + | Trunk of {keys: K.t BatFingerTree.t; children: address BatFingerTree.t} + + let empty = Leaf {keys= BatFingerTree.empty; values= BatFingerTree.empty} + + let rec lookup1' keys key bottom top = + let open Concepts.Ordering in + if bottom >= top then bottom, false + else + let mid = bottom + ((top - bottom) / 2) in + let node = BatFingerTree.get keys mid in + match K.compare node key with + | Equal -> mid, true + | Greater -> lookup1' keys key bottom mid + | Smaller -> lookup1' keys key (mid + 1) top + + let lookup1 keys key = lookup1' keys key 0 (BatFingerTree.size keys) + let keys_of = function Leaf {keys; _} -> keys | Trunk {keys; _} -> keys + + let of_bencode = + let open Concepts.Codec.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 + |> 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 + |> fmap as_list + |> Result.map (List.map f) + |> fmap sequence + |> Result.map BatFingerTree.of_list + in + function + | Tagged ('!', (Dict _ as data)) -> + let* keys = field "keys" data |> decode_list decode_key in + let* values = field "values" data |> decode_list decode_value in + Ok (Leaf {keys; values}) + | Tagged ('#', (Dict _ as data)) -> + let* keys = field "keys" data |> decode_list decode_key in + let* children = field "children" data |> decode_list decode_value in + Ok (Trunk {keys; children}) + | _ -> Error (Error.malformed_node ()) + + let from_blob blob = Concepts.Codec.Bencode.of_blob blob |> Utilities.Result.fmap of_bencode + + let to_bencode = + let open Concepts.Codec.Bencode in + (* Ditto. *) + let bencode_key k = + K.encode k |> Concepts.Representation.bytes_of_blob |> String.of_bytes |> fun s -> String s + in + let bencode_hash h = String (Concepts.Hash.to_raw_string h) in + function + | Leaf {keys; values} -> + Tagged + ( '!', + Dict + [ "keys", List (BatFingerTree.to_list keys |> List.map bencode_key); + "values", List (BatFingerTree.to_list values |> List.map bencode_hash) ] ) + | Trunk {keys; children} -> + 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 + + (* TODO: we should probably cache this inside the node itself rather than recalculating it every time. We could also allow the user to create "uninterned" nodes that are not storage-backed, that could be used for intermediates and the like. *) - let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob - - let find tx node = - let open Utilities.Result in - let* data = S.get tx node in - match data with - | None -> Ok None - | Some data -> - let* node = from_blob data in - Ok (Some node) - - let find' tx node = - let open Utilities.Result in - let* child = find tx node in - match child with - | Some child -> Ok child - | None -> failwith "A child node was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!" - - let rec lookup tx key node = - let open Utilities.Result in - let i, found = lookup1 (keys_of node) key in - match node with - | Leaf { values; _ } -> - if found then Ok (Some (BatFingerTree.get values i)) else Ok None - | Trunk { children; _ } -> - let* child = BatFingerTree.get children (if found then i+1 else i) |> find' tx in - lookup tx key child - - let persist tx node = - 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 - Ok addr - - type op = Update of address * node | Split of address * K.t * address - - let emplace i v ft = - let size = BatFingerTree.size ft in - if i < 0 || i > size then - invalid_arg "Merkle.emplace: index out of bounds" - else if size = 0 then - BatFingerTree.singleton v - else if i = size then - BatFingerTree.snoc ft v - else - let fl, fr = BatFingerTree.split_at ft i in - BatFingerTree.singleton v - |> BatFingerTree.append fl - |> (Fun.flip BatFingerTree.append) fr - - let insert1 key value node = - let i, present = lookup1 (keys_of node) key in - match node with - | Leaf ({ keys; values } as leaf) -> - if present then - Leaf { leaf with values = BatFingerTree.set values i value } - else - Leaf { keys = emplace i key keys; values = emplace i value values } - (* When in danger or in doubt: run in circles, scream and shout. *) - | Trunk _ -> failwith "Cannot insert a value on a trunk node. This is a bug in RNT!" - - let pivot_at ft i = - let l, r' = BatFingerTree.split_at ft i in - let r, p = BatFingerTree.front_exn r' in - l, p, r - - let split_at pivot = function - | Leaf { keys; values } -> - let kl, kr = BatFingerTree.split_at keys pivot in - let vl, vr = BatFingerTree.split_at values pivot in - let p = BatFingerTree.get kr 0 in - Leaf { keys = kl; values = vl }, - p, - Leaf { keys = kr; values = vr } - | Trunk { keys; children } -> - let kl, kp, kr = pivot_at keys pivot in - let cl, cr = BatFingerTree.split_at children (pivot + 1) in - Trunk { keys = kl; children = cl }, - kp, - Trunk { keys = kr; children = cr } - - (* FIXME: this works out to a geometric distribution with roughly 64 + let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob + + let find tx node = + let open Utilities.Result in + let* data = S.get tx node in + match data with + | None -> Ok None + | Some data -> + let* node = from_blob data in + Ok (Some node) + + let find' tx node = + let open Utilities.Result in + let* child = find tx node in + match child with + | Some child -> Ok child + | None -> + failwith + "A child node was not found on the underlying storage. Either your database is \ + corrupted, or this is a bug on RNT!" + + let rec lookup tx key node = + let open Utilities.Result in + let i, found = lookup1 (keys_of node) key in + match node with + | Leaf {values; _} -> if found then Ok (Some (BatFingerTree.get values i)) else Ok None + | Trunk {children; _} -> + let* child = BatFingerTree.get children (if found then i + 1 else i) |> find' tx in + lookup tx key child + + let persist tx node = + 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 + Ok addr + + type op = Update of address * node | Split of address * K.t * address + + let emplace i v ft = + let size = BatFingerTree.size ft in + if i < 0 || i > size then invalid_arg "Merkle.emplace: index out of bounds" + else if size = 0 then BatFingerTree.singleton v + else if i = size then BatFingerTree.snoc ft v + else + let fl, fr = BatFingerTree.split_at ft i in + BatFingerTree.singleton v |> BatFingerTree.append fl |> (Fun.flip BatFingerTree.append) fr + + let insert1 key value node = + let i, present = lookup1 (keys_of node) key in + match node with + | Leaf ({keys; values} as leaf) -> + if present then Leaf {leaf with values= BatFingerTree.set values i value} + else Leaf {keys= emplace i key keys; values= emplace i value values} + (* When in danger or in doubt: run in circles, scream and shout. *) + | Trunk _ -> failwith "Cannot insert a value on a trunk node. This is a bug in RNT!" + + let pivot_at ft i = + let l, r' = BatFingerTree.split_at ft i in + let r, p = BatFingerTree.front_exn r' in + l, p, r + + let split_at pivot = function + | Leaf {keys; values} -> + let kl, kr = BatFingerTree.split_at keys pivot in + let vl, vr = BatFingerTree.split_at values pivot in + let p = BatFingerTree.get kr 0 in + Leaf {keys= kl; values= vl}, p, Leaf {keys= kr; values= vr} + | Trunk {keys; children} -> + let kl, kp, kr = pivot_at keys pivot in + let cl, cr = BatFingerTree.split_at children (pivot + 1) in + Trunk {keys= kl; children= cl}, kp, Trunk {keys= kr; children= cr} + + (* FIXME: this works out to a geometric distribution with roughly 64 keys per node. Some of the consequences of this are that: - most of our nodes will end up with one or a few elements, which would make our trees taller than they would normally need to be @@ -208,133 +205,128 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct node size. See https://www.dolthub.com/docs/architecture/storage-engine/prolly-tree/#controlling-chunk-size *) - let should_split = Concepts.Hash.pick 6 - - let hash_of_keys ks = - let buffer = Buffer.create 1024 in - BatFingerTree.iter - (fun k -> - K.encode k - |> Concepts.Representation.bytes_of_blob - |> Buffer.add_bytes buffer) - ks; - Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) - - let split_position keys = - let rec loop left right = - match BatFingerTree.front right with - | None -> None - | Some (tail, head) -> - (* TODO: rolling hash *) - let left' = BatFingerTree.snoc left head in - let hash = hash_of_keys left' in - if should_split hash then - Some (BatFingerTree.size left) - else - loop left' tail - in - loop BatFingerTree.empty keys - - let commit_node tx node = - let open Utilities.Result in - match split_position (keys_of node) with - | Some i -> - let l, p, r = split_at i node in - let* l_addr = persist tx l in - let* r_addr = persist tx r in - Ok (Split (l_addr, p, r_addr)) - | None -> - let* addr = persist tx node in - Ok (Update (addr, node)) - - let rec insert' tx key value node = - let open Utilities.Result in - match node with - | Leaf _ -> - insert1 key value node - |> commit_node tx - | Trunk { keys; children } -> - let i, found = lookup1 keys key in - let i = if found then i+1 else i in - let* child = BatFingerTree.get children i |> find' tx in - let* r = insert' tx key value child in - match r with - | Update (addr, _) -> - Trunk { keys; children = BatFingerTree.set children i addr } - |> commit_node tx - | Split (l, p, r) -> - Trunk { keys = emplace i p keys; - children = BatFingerTree.set children i l |> emplace (i + 1) r } - |> commit_node tx - - let insert tx key value node = - let open Utilities.Result in - let* op = insert' tx key value node in - match op with - | Update (_, node) -> Ok node - | Split (l, p, r) -> - let new_root = - Trunk { keys = BatFingerTree.singleton p; - children = BatFingerTree.empty - |> (Fun.flip BatFingerTree.snoc) l - |> (Fun.flip BatFingerTree.snoc) r } in - let* _ = persist tx new_root in - Ok new_root - - let remove tx key node = failwith "TODO" [@@warning "-27"] -end + let should_split = Concepts.Hash.pick 6 + + let hash_of_keys ks = + let buffer = Buffer.create 1024 in + BatFingerTree.iter + (fun k -> K.encode k |> Concepts.Representation.bytes_of_blob |> Buffer.add_bytes buffer) + ks; + Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) + + let split_position keys = + let rec loop left right = + match BatFingerTree.front right with + | None -> None + | Some (tail, head) -> + (* TODO: rolling hash *) + let left' = BatFingerTree.snoc left head in + let hash = hash_of_keys left' in + if should_split hash then Some (BatFingerTree.size left) else loop left' tail + in + loop BatFingerTree.empty keys + + let commit_node tx node = + let open Utilities.Result in + match split_position (keys_of node) with + | Some i -> + let l, p, r = split_at i node in + let* l_addr = persist tx l in + let* r_addr = persist tx r in + Ok (Split (l_addr, p, r_addr)) + | None -> + let* addr = persist tx node in + Ok (Update (addr, node)) + + let rec insert' tx key value node = + let open Utilities.Result in + match node with + | Leaf _ -> insert1 key value node |> commit_node tx + | Trunk {keys; children} -> ( + let i, found = lookup1 keys key in + let i = if found then i + 1 else i in + let* child = BatFingerTree.get children i |> find' tx in + let* r = insert' tx key value child in + match r with + | Update (addr, _) -> + Trunk {keys; children= BatFingerTree.set children i addr} |> commit_node tx + | Split (l, p, r) -> + Trunk + { keys= emplace i p keys; + children= BatFingerTree.set children i l |> emplace (i + 1) r } + |> commit_node tx ) + + let insert tx key value node = + let open Utilities.Result in + let* op = insert' tx key value node in + match op with + | Update (_, node) -> Ok node + | Split (l, p, r) -> + let new_root = + Trunk + { keys= BatFingerTree.singleton p; + children= + BatFingerTree.empty + |> (Fun.flip BatFingerTree.snoc) l + |> (Fun.flip BatFingerTree.snoc) r } + in + let* _ = persist tx new_root in + Ok new_root + + let remove tx key node = failwith "TODO" [@@warning "-27"] + end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig type address type node val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result - val empty : node - val hash_of : node -> address - val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result end -module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct - module T = Make (S) (K) - - type address = T.address - type node = T.node - - open Utilities.Result - - 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 - Ok addr - - let retrieve tx addr = - let* data = S.get tx addr in - match data with - | None -> Ok None - | Some data -> - let* v = V.decode data in - Ok (Some v) - - let find = T.find - let empty = T.empty - let hash_of = T.hash_of - - let insert tx k v node = - let* addr = intern tx v in - T.insert tx k addr node - - let remove = T.remove - - let lookup tx k node = - let* addr = T.lookup tx k node in - match addr with - | None -> Ok None - | Some addr -> retrieve tx addr - -end +module Interface : INTERFACE = +functor + (S : Abstract.Storage.STORAGE) + (K : KEY) + (V : VALUE) + -> + struct + module T = Make (S) (K) + + type address = T.address + type node = T.node + + open Utilities.Result + + 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 + Ok addr + + let retrieve tx addr = + let* data = S.get tx addr in + match data with + | None -> Ok None + | Some data -> + let* v = V.decode data in + Ok (Some v) + + let find = T.find + let empty = T.empty + let hash_of = T.hash_of + + let insert tx k v node = + let* addr = intern tx v in + T.insert tx k addr node + + let remove = T.remove + + let lookup tx k node = + let* addr = T.lookup tx k node in + match addr with None -> Ok None | Some addr -> retrieve tx addr + end diff --git a/test/Helpers.ml b/test/Helpers.ml index 784170c..aa24160 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -33,12 +33,12 @@ module Storage = struct module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct let with_connection f dir () = with_temporary_directory dir begin fun dir -> - begin - let open Utilities.Result in - let* conn = S.connect (C.configure dir) in - Ok (f conn) - end - |> condition_as_failure + begin + let open Utilities.Result in + let* conn = S.connect (C.configure dir) in + Ok (f conn) + end + |> condition_as_failure end end end diff --git a/test/test_rnt.ml b/test/test_rnt.ml index d46be1e..584ea65 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -2,6 +2,8 @@ let all_suites = Unit.Concepts.Serialization.suites () @ Unit.Backend.Storage.suites () @ Unit.Backend.Lifecycle.suites () + @ [Unit.Backend.ObjectManager.suite] @ Unit.Kernel.Merkle.suites () + @ [Unit.Kernel.Runtime.suite] let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/backend/Storage.ml b/test/unit/backend/Storage.ml index 76bda8b..970e2c4 100644 --- a/test/unit/backend/Storage.ml +++ b/test/unit/backend/Storage.ml @@ -2,7 +2,6 @@ open Rnt module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct open Alcotest - module H = Helpers.Storage.Make (S) (C) let storage_and_retrieval conn = @@ -26,7 +25,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let suite prefix = ( "storage/" ^ prefix, - [test_case "storage-and-retrieval" `Quick (H.with_connection storage_and_retrieval "storage-test")] ) + [ test_case "storage-and-retrieval" `Quick + (H.with_connection storage_and_retrieval "storage-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml index f12182a..ae15cf1 100644 --- a/test/unit/kernel/Merkle.ml +++ b/test/unit/kernel/Merkle.ml @@ -10,7 +10,6 @@ end module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct open Alcotest - module H = Helpers.Storage.Make (S) (C) module T = Rnt.Kernel.Merkle.Interface (S) (StringKey) (StringKey) @@ -20,10 +19,11 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = begin let open Utilities.Result in let* tx = S.start conn in - let* node = T.empty - |> T.insert tx "k1" "v1" - |> fmap (T.insert tx "k2" "v2") - |> fmap (T.insert tx "k3" "v3") + let* node = + T.empty + |> T.insert tx "k1" "v1" + |> fmap (T.insert tx "k2" "v2") + |> fmap (T.insert tx "k3" "v3") in let* node' = T.insert tx "k3" "toodles" node in let* v1 = T.lookup tx "k1" node in @@ -46,10 +46,11 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = begin let open Utilities.Result in let* tx = S.start conn in - let* node = T.empty - |> T.insert tx "k1" "v1" - |> fmap (T.insert tx "k2" "v2") - |> fmap (T.insert tx "k3" "v3") + let* node = + T.empty + |> T.insert tx "k1" "v1" + |> fmap (T.insert tx "k2" "v2") + |> fmap (T.insert tx "k3" "v3") in let* () = S.commit tx in Ok (T.hash_of node) @@ -78,8 +79,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let suite prefix = ( "merkle/" ^ prefix, - [test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test"); - test_case "persistence" `Quick (H.with_connection persistence "merkle-test")]) + [ test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test"); + test_case "persistence" `Quick (H.with_connection persistence "merkle-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) -- cgit v1.2.3