path: root/lib/storable.ml

module Wire = struct
  let split_once ch value =
    match String.index_opt value ch with
    | None -> None
    | Some index ->
        Some
          ( String.sub value 0 index,
            String.sub value (index + 1) (String.length value - index - 1) )

  let lines bytes =
    bytes |> Bytes.to_string |> String.split_on_char '\n'
    |> List.filter (fun line -> String.trim line <> "")

  let fields bytes =
    lines bytes
    |> List.filter_map (fun line -> split_once '=' line)
    |> List.map (fun (key, value) -> (String.trim key, String.trim value))

  let require_type expected fields =
    match List.assoc_opt "type" fields with
    | Some actual when actual = expected -> ()
    | Some actual ->
        invalid_arg
          (Printf.sprintf "expected storable type %S, got %S" expected actual)
    | None -> invalid_arg "missing storable type"

  let values key fields =
    List.filter_map (fun (k, v) -> if k = key then Some v else None) fields

  let required key fields =
    match List.assoc_opt key fields with
    | Some value -> value
    | None -> invalid_arg ("missing storable field: " ^ key)

  let attribute value =
    match split_once ':' value with
    | Some pair -> pair
    | None -> invalid_arg ("invalid attribute field: " ^ value)

  let encode fields =
    fields
    |> List.map (fun (key, value) -> key ^ "=" ^ value)
    |> String.concat "\n" |> fun value -> Bytes.of_string (value ^ "\n")
end

module Tuple = struct
  type t = { relation : string; attributes : (string * string) list }

  let to_bytes tuple =
    Wire.encode
      ([ ("type", "tuple"); ("relation", tuple.relation) ]
       @ List.map
           (fun (name, value) -> ("attribute", name ^ ":" ^ value))
           tuple.attributes)

  let of_bytes bytes =
    let fields = Wire.fields bytes in
    Wire.require_type "tuple" fields;
    {
      relation = Wire.required "relation" fields;
      attributes = List.map Wire.attribute (Wire.values "attribute" fields);
    }
end

module Relation = struct
  type t = {
    name : string;
    schema : (string * string) list;
    (** Hex Merkle root of the relation's tuple set.  Empty string = empty relation. *)
    tree_pointer : string;
  }

  let to_bytes relation =
    Wire.encode
      ([ ("type", "relation"); ("name", relation.name); ("kind", "stored");
         ("tree_pointer", relation.tree_pointer) ]
       @ List.map
           (fun (name, domain) -> ("attribute", name ^ ":" ^ domain))
           relation.schema)

  let of_bytes bytes =
    let fields = Wire.fields bytes in
    Wire.require_type "relation" fields;
    {
      name         = Wire.required "name" fields;
      schema       = List.map Wire.attribute (Wire.values "attribute" fields);
      tree_pointer = Option.value (List.assoc_opt "tree_pointer" fields) ~default:"";
    }
end

module Multigroup = struct
  type t = { name : string; relations : Relation.t list }

  (* Wire format: "name|attr1:dom1,attr2:dom2|<merkle_root>"
     The third segment is the Merkle root hex; empty string = empty relation.
     A fourth segment for constraints is reserved but not yet implemented.
     TODO: add constraints serialisation once a canonical sexp representation
     is agreed upon (two syntactically distinct bodies may be semantically
     equivalent — the round-trip must account for that). *)
  let relation_value relation =
    let attrs =
      relation.Relation.schema
      |> List.map (fun (name, domain) -> name ^ ":" ^ domain)
      |> String.concat ","
    in
    relation.name ^ "|" ^ attrs ^ "|" ^ relation.tree_pointer

  let parse_relation value =
    match Wire.split_once '|' value with
    | None -> { Relation.name = value; schema = []; tree_pointer = "" }
    | Some (name, rest) ->
        let attrs_str, tree_pointer =
          match Wire.split_once '|' rest with
          | None         -> (rest, "")
          | Some (a, tp) -> (a, tp)
        in
        let schema =
          if attrs_str = "" then []
          else attrs_str |> String.split_on_char ',' |> List.map Wire.attribute
        in
        { Relation.name; schema; tree_pointer }

  let to_bytes multigroup =
    Wire.encode
      ([ ("type", "multigroup"); ("name", multigroup.name) ]
       @ List.map
           (fun relation -> ("relation", relation_value relation))
           multigroup.relations)

  let of_bytes bytes =
    let fields = Wire.fields bytes in
    Wire.require_type "multigroup" fields;
    {
      name = Wire.required "name" fields;
      relations = List.map parse_relation (Wire.values "relation" fields);
    }
end