diff options
| -rw-r--r-- | lib/concepts/Branch.ml | 49 | ||||
| -rw-r--r-- | lib/concepts/Branch.mli | 9 | ||||
| -rw-r--r-- | lib/concepts/Multigroup.ml | 51 | ||||
| -rw-r--r-- | lib/concepts/Multigroup.mli | 9 | ||||
| -rw-r--r-- | lib/concepts/Object.ml | 64 | ||||
| -rw-r--r-- | lib/concepts/Object.mli | 45 | ||||
| -rw-r--r-- | lib/concepts/Relation.ml | 81 | ||||
| -rw-r--r-- | lib/concepts/Relation.mli | 15 | ||||
| -rw-r--r-- | test/test_rnt.ml | 6 | ||||
| -rw-r--r-- | test/unit/concepts/Serialization.ml | 45 |
10 files changed, 373 insertions, 1 deletions
diff --git a/lib/concepts/Branch.ml b/lib/concepts/Branch.ml new file mode 100644 index 0000000..cd4213b --- /dev/null +++ b/lib/concepts/Branch.ml @@ -0,0 +1,49 @@ +type address = Hash.hash + +type t = + { name: string; + target: address } + +module Field = struct + let name = "name" + let target = "target" +end + +module Error = struct + open Condition + + let malformed_branch () = + condition "branch-malformed" "A branch representation did not conform to what was expected" + empty + + let malformed_hash length = + condition "branch-malformed-hash" "A branch target root was not a valid hash" + ("length" |=| Value.Integer length) +end + +let make ~name ~target = {name; target} + +let name branch = branch.name +let target branch = branch.target + +module Body = struct + type nonrec t = t + + let tag = 'b' + let malformed = Error.malformed_branch + + 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 ] + + let of_fields data = + let open Utilities.Result in + let* name = Object.Field.require_string Field.name data in + let* target = Object.Field.require_address ~malformed:Error.malformed_hash Field.target data in + Ok {name; target} +end + +include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Branch.mli b/lib/concepts/Branch.mli new file mode 100644 index 0000000..0e7e9f9 --- /dev/null +++ b/lib/concepts/Branch.mli @@ -0,0 +1,9 @@ +type t +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/Multigroup.ml b/lib/concepts/Multigroup.ml new file mode 100644 index 0000000..863cd26 --- /dev/null +++ b/lib/concepts/Multigroup.ml @@ -0,0 +1,51 @@ +type address = Hash.hash + +type t = + { name: string; + relations: address } + +module Field = struct + let name = "name" + let relations = "relations" +end + +module Error = struct + open Condition + + let malformed_multigroup () = + condition "multigroup-malformed" + "A multigroup representation did not conform to what was expected" empty + + let malformed_hash length = + condition "multigroup-malformed-hash" "A multigroup relation root was not a valid hash" + ("length" |=| Value.Integer length) +end + +let make ~name ~relations = {name; relations} + +let name multigroup = multigroup.name +let relations multigroup = multigroup.relations + +module Body = struct + type nonrec t = t + + let tag = 'm' + let malformed = Error.malformed_multigroup + + 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; + Field.relations, Object.Field.address multigroup.relations ] + + let of_fields data = + let open Utilities.Result in + let* name = Object.Field.require_string Field.name data in + let* relations = + Object.Field.require_address ~malformed:Error.malformed_hash Field.relations data + in + Ok {name; relations} +end + +include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Multigroup.mli b/lib/concepts/Multigroup.mli new file mode 100644 index 0000000..1a76dce --- /dev/null +++ b/lib/concepts/Multigroup.mli @@ -0,0 +1,9 @@ +type t +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 new file mode 100644 index 0000000..22fb14a --- /dev/null +++ b/lib/concepts/Object.ml @@ -0,0 +1,64 @@ +type bencode = Codec.Bencode.t + +module Bencode = Codec.Bencode + +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 + +module type OBJECT = S + +module Field = struct + let string value = Bencode.String value + let address address = Bencode.String (Hash.to_raw_string address) + + let require_string key data = + Codec.Bencode.field key data |> Utilities.Result.fmap Codec.Bencode.as_string + + let require_address ~malformed key data = + let open Utilities.Result in + let* raw = require_string key data in + if String.length raw = Hash.size then Ok (Hash.of_raw_string raw) + else Error (malformed (String.length raw)) +end + +module Codec = struct + module type BODY = sig + type t + + val tag : char + val malformed : unit -> Condition.condition + val equal : t -> t -> bool + val fields : t -> (string * bencode) list + val of_fields : bencode -> (t, Condition.condition) result + end + + module Make (B : BODY) = struct + type t = B.t + + let equal = B.equal + 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 + | _ -> 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 +end diff --git a/lib/concepts/Object.mli b/lib/concepts/Object.mli new file mode 100644 index 0000000..e132673 --- /dev/null +++ b/lib/concepts/Object.mli @@ -0,0 +1,45 @@ +type bencode = Codec.Bencode.t + +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 + +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 : + malformed:(int -> Condition.condition) -> + string -> + bencode -> + (Hash.hash, Condition.condition) result +end + +module Codec : sig + module type BODY = sig + type t + + val tag : char + val malformed : unit -> Condition.condition + val equal : t -> t -> bool + val fields : t -> (string * bencode) list + val of_fields : bencode -> (t, Condition.condition) result + end + + module Make (B : BODY) : S with type t = B.t +end diff --git a/lib/concepts/Relation.ml b/lib/concepts/Relation.ml new file mode 100644 index 0000000..a4fb341 --- /dev/null +++ b/lib/concepts/Relation.ml @@ -0,0 +1,81 @@ +type address = Hash.hash +type schema = string BatMap.String.t + +type t = + { name: string; + tuples: address; + schema: schema } + +module Field = struct + let name = "name" + let tuples = "tuples" + let schema = "schema" +end + +module Error = struct + open Condition + + let malformed_relation () = + condition "relation-malformed" "A relation representation did not conform to what was expected" + empty + + let malformed_hash length = + condition "relation-malformed-hash" "A relation tuple root was not a valid hash" + ("length" |=| Value.Integer length) +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 + +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) ) + +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) ) + |> sequence + |> Result.map schema_of_list + +module Body = struct + type nonrec t = t + + let tag = 'r' + let malformed = Error.malformed_relation + + let equal left right = + left.name = right.name + && Hash.hash_equals left.tuples right.tuples + && BatMap.String.equal String.equal left.schema right.schema + + let fields relation = + [ Field.name, Object.Field.string relation.name; + Field.schema, schema_to_bencode relation.schema; + Field.tuples, Object.Field.address relation.tuples ] + + let of_fields data = + let open Utilities.Result in + let* name = Object.Field.require_string Field.name data in + let* tuples = Object.Field.require_address ~malformed:Error.malformed_hash Field.tuples data in + let* schema_data = Codec.Bencode.field Field.schema data in + let* schema = schema_of_bencode schema_data in + Ok {name; tuples; schema} +end + +include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Relation.mli b/lib/concepts/Relation.mli new file mode 100644 index 0000000..5319a3d --- /dev/null +++ b/lib/concepts/Relation.mli @@ -0,0 +1,15 @@ +type t +type address = Hash.hash +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/test/test_rnt.ml b/test/test_rnt.ml index 7173837..a2a8e84 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -1,2 +1,6 @@ -let all_suites = Unit.Backend.Storage.suites () @ Unit.Backend.Lifecycle.suites () +let all_suites = + Unit.Concepts.Serialization.suites () + @ Unit.Backend.Storage.suites () + @ Unit.Backend.Lifecycle.suites () + let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/concepts/Serialization.ml b/test/unit/concepts/Serialization.ml new file mode 100644 index 0000000..9df8d26 --- /dev/null +++ b/test/unit/concepts/Serialization.ml @@ -0,0 +1,45 @@ +module Branch = Rnt.Concepts.Branch +module Hash = Rnt.Concepts.Hash +module Multigroup = Rnt.Concepts.Multigroup +module Relation = Rnt.Concepts.Relation + +let fail_condition c = Alcotest.fail (Rnt.Concepts.Condition.to_string_hum c) +let hash text = Hash.hash_of_bytes (Bytes.of_string text) + +let check_hash label expected actual = + Alcotest.(check bool) label true (Hash.hash_equals expected actual) + +let test_branch_round_trips () = + let expected = Branch.make ~name:"master" ~target:(hash "master-target") in + match Branch.(expected |> to_bytes |> of_bytes) with + | Ok actual -> + Alcotest.(check string) "name" (Branch.name expected) (Branch.name actual); + check_hash "target" (Branch.target expected) (Branch.target actual) + | Error c -> fail_condition c + +let test_multigroup_round_trips () = + let expected = Multigroup.make ~name:"public" ~relations:(hash "public-relations") in + match Multigroup.(expected |> to_bytes |> of_bytes) with + | Ok actual -> + Alcotest.(check string) "name" (Multigroup.name expected) (Multigroup.name actual); + check_hash "relations" (Multigroup.relations expected) (Multigroup.relations actual) + | Error c -> fail_condition c + +let test_relation_round_trips () = + let schema = Relation.schema_of_list ["tag", "string"; "name", "string"] in + let expected = Relation.make ~name:"users" ~tuples:(hash "users-tuples") ~schema in + match Relation.(expected |> to_bytes |> of_bytes) with + | Ok actual -> + Alcotest.(check string) "name" (Relation.name expected) (Relation.name actual); + check_hash "tuples" (Relation.tuples expected) (Relation.tuples actual); + Alcotest.(check (list (pair string string))) + "schema" + (Relation.schema expected |> Relation.schema_to_list) + (Relation.schema actual |> Relation.schema_to_list) + | Error c -> fail_condition c + +let suites () = + [ ( "concepts/serialization", + [ Alcotest.test_case "branch round-trips" `Quick test_branch_round_trips; + Alcotest.test_case "multigroup round-trips" `Quick test_multigroup_round_trips; + Alcotest.test_case "relation round-trips" `Quick test_relation_round_trips ] ) ] |