Serialize runtime objects: Multigroup, Branch & Relation

8 files changed, 323 insertions, 0 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