aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Utilities.ml14
-rw-r--r--lib/backend/managers/Lifecycle.ml3
-rw-r--r--lib/concepts/Branch.ml13
-rw-r--r--lib/concepts/Branch.mli1
-rw-r--r--lib/concepts/Codec.ml102
-rw-r--r--lib/concepts/Hash.ml10
-rw-r--r--lib/concepts/Multigroup.ml10
-rw-r--r--lib/concepts/Multigroup.mli1
-rw-r--r--lib/concepts/Object.ml7
-rw-r--r--lib/concepts/Object.mli4
-rw-r--r--lib/concepts/Ordering.ml3
-rw-r--r--lib/concepts/Relation.ml18
-rw-r--r--lib/concepts/Relation.mli2
-rw-r--r--lib/kernel/Merkle.ml568
-rw-r--r--test/Helpers.ml12
-rw-r--r--test/test_rnt.ml2
-rw-r--r--test/unit/backend/Storage.ml4
-rw-r--r--test/unit/kernel/Merkle.ml23
18 files changed, 426 insertions, 371 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml
index f2c96a7..9ae0119 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 5f336ef..d104249 100644
--- a/lib/backend/managers/Lifecycle.ml
+++ b/lib/backend/managers/Lifecycle.ml
@@ -79,8 +79,7 @@ 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 57c46b3..cd4213b 100644
--- a/lib/concepts/Branch.ml
+++ b/lib/concepts/Branch.ml
@@ -1,5 +1,8 @@
type address = Hash.hash
-type t = {name: string; target: address}
+
+type t =
+ { name: string;
+ target: address }
module Field = struct
let name = "name"
@@ -19,6 +22,7 @@ module Error = struct
end
let make ~name ~target = {name; target}
+
let name branch = branch.name
let target branch = branch.target
@@ -27,10 +31,13 @@ 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 3fb6ebe..0e7e9f9 100644
--- a/lib/concepts/Branch.mli
+++ b/lib/concepts/Branch.mli
@@ -4,5 +4,6 @@ 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 97039c3..758d718 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,19 +16,21 @@ module Error = struct
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"
@@ -47,37 +49,38 @@ end
- List "l" <element>* "e"
- Dict "d" (<String key> <value>)* "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")
@@ -89,7 +92,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 =
@@ -103,7 +106,8 @@ module Bencode = struct
| None -> Error (Error.malformed_integer digits)
end
else begin
- advance (); scan ()
+ advance ();
+ scan ()
end
in
scan ()
@@ -111,44 +115,43 @@ 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
@@ -156,17 +159,24 @@ 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 a84c60d..aac7428 100644
--- a/lib/concepts/Hash.ml
+++ b/lib/concepts/Hash.ml
@@ -2,16 +2,22 @@
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 b8fc743..863cd26 100644
--- a/lib/concepts/Multigroup.ml
+++ b/lib/concepts/Multigroup.ml
@@ -1,5 +1,8 @@
type address = Hash.hash
-type t = {name: string; relations: address}
+
+type t =
+ { name: string;
+ relations: address }
module Field = struct
let name = "name"
@@ -19,6 +22,7 @@ module Error = struct
end
let make ~name ~relations = {name; relations}
+
let name multigroup = multigroup.name
let relations multigroup = multigroup.relations
@@ -27,7 +31,9 @@ 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 ef0f8ea..1a76dce 100644
--- a/lib/concepts/Multigroup.mli
+++ b/lib/concepts/Multigroup.mli
@@ -4,5 +4,6 @@ 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 aacbda6..22fb14a 100644
--- a/lib/concepts/Object.ml
+++ b/lib/concepts/Object.ml
@@ -6,10 +6,13 @@ 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
@@ -48,11 +51,13 @@ 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 7b0c4fd..e132673 100644
--- a/lib/concepts/Object.mli
+++ b/lib/concepts/Object.mli
@@ -4,10 +4,13 @@ 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
@@ -17,6 +20,7 @@ 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 8952b41..42b20e5 100644
--- a/lib/concepts/Ordering.ml
+++ b/lib/concepts/Ordering.ml
@@ -1,3 +1,4 @@
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 1194804..a4fb341 100644
--- a/lib/concepts/Relation.ml
+++ b/lib/concepts/Relation.ml
@@ -1,6 +1,10 @@
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"
@@ -21,27 +25,31 @@ 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 d370578..5319a3d 100644
--- a/lib/concepts/Relation.mli
+++ b/lib/concepts/Relation.mli
@@ -5,9 +5,11 @@ 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 913c9f1..5bd427f 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -13,188 +13,191 @@ 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 persist : S.transaction -> node -> (address, 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
@@ -205,128 +208,133 @@ functor
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 aa24160..784170c 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 584ea65..d46be1e 100644
--- a/test/test_rnt.ml
+++ b/test/test_rnt.ml
@@ -2,8 +2,6 @@ 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 970e2c4..76bda8b 100644
--- a/test/unit/backend/Storage.ml
+++ b/test/unit/backend/Storage.ml
@@ -2,6 +2,7 @@ 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 =
@@ -25,8 +26,7 @@ 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 ae15cf1..f12182a 100644
--- a/test/unit/kernel/Merkle.ml
+++ b/test/unit/kernel/Merkle.ml
@@ -10,6 +10,7 @@ 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)
@@ -19,11 +20,10 @@ 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,11 +46,10 @@ 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)
@@ -79,8 +78,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)