From 0a88f1887cf2e31adacdb5a1c852ff7164009dc8 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Sat, 3 Feb 2018 14:48:08 -0500 Subject: [PATCH] Data_encoding: binary description printing --- docs/doc_gen/rpcs/rpc_doc.ml | 6 +- src/bin_client/client_rpc_commands.ml | 29 +- src/lib_data_encoding/binary_description.ml | 412 ++++++++++++++++ src/lib_data_encoding/binary_description.mli | 10 + src/lib_data_encoding/binary_schema.ml | 481 +++++++++++++++++++ src/lib_data_encoding/binary_schema.mli | 54 +++ src/lib_data_encoding/data_encoding.ml | 2 + src/lib_data_encoding/data_encoding.mli | 8 + src/lib_rpc/RPC_description.mli | 2 +- src/lib_rpc/RPC_encoding.ml | 18 +- src/lib_rpc/RPC_encoding.mli | 6 +- src/lib_rpc/RPC_service.mli | 2 +- 12 files changed, 1008 insertions(+), 22 deletions(-) create mode 100644 src/lib_data_encoding/binary_description.ml create mode 100644 src/lib_data_encoding/binary_description.mli create mode 100644 src/lib_data_encoding/binary_schema.ml create mode 100644 src/lib_data_encoding/binary_schema.mli diff --git a/docs/doc_gen/rpcs/rpc_doc.ml b/docs/doc_gen/rpcs/rpc_doc.ml index c30501df9..f0709c005 100644 --- a/docs/doc_gen/rpcs/rpc_doc.ml +++ b/docs/doc_gen/rpcs/rpc_doc.ml @@ -200,7 +200,7 @@ module Description = struct pp_button ppf ~default:true ~shortlabel:"descr" ~content:"Description" target_ref ; - Option.iter service.input ~f: begin fun __ -> + Option.iter service.input ~f: begin fun _ -> pp_button ppf ~default:false ~shortlabel:"input" ~content:"Input format" target_ref @@ -212,14 +212,14 @@ module Description = struct pp_content ppf ~tag:"p" ~shortlabel:"descr" target_ref pp_description service ; - Option.iter service.input ~f: begin fun schema -> + Option.iter service.input ~f: begin fun (schema, _) -> pp_content ppf ~tag:"pre" ~shortlabel:"input" target_ref Json_schema.pp schema ; end ; pp_content ppf ~tag:"pre" ~shortlabel:"output" target_ref - Json_schema.pp service.output ; + Json_schema.pp (fst service.output) ; end end diff --git a/src/bin_client/client_rpc_commands.ml b/src/bin_client/client_rpc_commands.ml index 1a0f4a938..4987ef6ae 100644 --- a/src/bin_client/client_rpc_commands.ml +++ b/src/bin_client/client_rpc_commands.ml @@ -301,12 +301,12 @@ let schema meth url (cctxt : #Client_context.full) = "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> return () | { input = Some input ; output } -> - let json = `O [ "input", Json_schema.to_json input ; - "output", Json_schema.to_json output ] in + let json = `O [ "input", Json_schema.to_json (fst input) ; + "output", Json_schema.to_json (fst output) ] in cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> return () | { input = None ; output } -> - let json = `O [ "output", Json_schema.to_json output ] in + let json = `O [ "output", Json_schema.to_json (fst output) ] in cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> return () end @@ -315,9 +315,14 @@ let schema meth url (cctxt : #Client_context.full) = "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> return () -let format meth url (cctxt : #Client_context.io_rpcs) = +let format binary meth url (cctxt : #Client_context.io_rpcs) = let args = String.split '/' url in let open RPC_description in + let pp = + if binary then + (fun ppf (_, schema) -> Data_encoding.Binary_schema.pp ppf schema) + else + (fun ppf (schema, _) -> Json_schema.pp ppf schema) in RPC_description.describe cctxt ~recurse:false args >>=? function | Static { services } -> begin match RPC_service.MethMap.find meth services with @@ -331,15 +336,15 @@ let format meth url (cctxt : #Client_context.io_rpcs) = @[Input format:@,%a@]@,\ @[Output format:@,%a@]@,\ @]" - Json_schema.pp input - Json_schema.pp output >>= fun () -> + pp input + pp output >>= fun () -> return () | { input = None ; output } -> cctxt#message "@[\ @[Output format:@,%a@]@,\ @]" - Json_schema.pp output >>= fun () -> + pp output >>= fun () -> return () end | _ -> @@ -381,7 +386,7 @@ let call meth raw_url (cctxt : #Client_context.full) = cctxt#generic_json_call meth uri >>=? display_answer cctxt | { input = Some input } -> - fill_in ~show_optionals:false input >>= function + fill_in ~show_optionals:false (fst input) >>= function | Error msg -> cctxt#error "%s" msg >>= fun () -> return () @@ -470,12 +475,16 @@ let commands = [ command ~group ~desc: "Get the humanoid readable input and output formats of an RPC." - no_options + (args1 + (switch + ~doc:"Binary format" + ~short:'b' + ~long:"binary" ())) (prefixes [ "rpc" ; "format"] @@ meth_params @@ string ~name: "url" ~desc: "the RPC URL" @@ stop) - (fun () -> format) ; + format ; command ~group ~desc: "Call an RPC with the GET method." diff --git a/src/lib_data_encoding/binary_description.ml b/src/lib_data_encoding/binary_description.ml new file mode 100644 index 000000000..04b4ffbca --- /dev/null +++ b/src/lib_data_encoding/binary_description.ml @@ -0,0 +1,412 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let unopt_lazy func = function + | None -> func () + | Some x -> x + +type recursives = string list +type references = { descriptions : (string * Binary_schema.toplevel_encoding) list } [@@unwrapped] + +(* Simple Union find implementation, there are several optimizations + that give UF it's usual time complexity that could be added. + If this is a bottleneck, they're easy to add. *) +module UF : sig + type t + val add : t -> Binary_schema.description -> unit + val find : t -> string -> Binary_schema.description + val union : t -> new_cannonical:Binary_schema.description -> existing:string -> unit + val empty : unit -> t + val pp : Format.formatter -> t -> unit +end = struct + open Binary_schema + type ele = Ref of string | Root of description + type t = (string, ele) Hashtbl.t + let add t x = Hashtbl.replace t x.name (Root x) + let rec find tbl key = + match Hashtbl.find tbl key with + | Ref s -> find tbl s + | Root desc -> desc + + let union tbl ~new_cannonical ~existing = + add tbl new_cannonical ; + let root = find tbl existing in + if root.name = new_cannonical.name + then () + else Hashtbl.replace tbl root.name (Ref new_cannonical.name) + + let empty () = Hashtbl.create 128 + + let pp ppf tbl = + Format.fprintf ppf "@[UF:@,%a@]" + (fun ppf -> + (Hashtbl.iter (fun k v -> + Format.fprintf ppf "'%s' ---> %a@," + k (fun ppf -> function + | Root { name } -> Format.fprintf ppf "Root '%s'" name + | Ref s -> Format.fprintf ppf "Ref '%s'" s) v))) tbl +end + +let fixup_references uf = + let open Binary_schema in + let rec fixup_layout = function + | Ref s -> Ref (UF.find uf s).name + | Enum (i, name) -> Enum (i, (UF.find uf name).name) + | Seq layout -> Seq (fixup_layout layout) + | (Zero_width + | Int _ + | Bool + | RangedInt (_, _) + | RangedFloat (_, _) + | Float + | Bytes + | String) as enc -> enc in + let field = function + | Named_field (name, kind, layout) -> + Named_field (name, kind, fixup_layout layout) + | Anonymous_field (kind, layout) -> + Anonymous_field (kind, fixup_layout layout) + | Dynamic_field i -> + Dynamic_field i + | (Option_indicator_field _) as field -> field in + function + | Obj { fields } -> Obj { fields = List.map field fields } + | Cases ({ cases } as x) -> + Cases { x with + cases = List.map + (fun (i, name, fields) -> + (i, name, List.map field fields)) cases } + | (Int_enum _ as ie) -> ie + +let z_reference_name = "Z.t" + +let z_reference_description = + "A variable length sequence of bytes, encoding a Zarith number. \ + Each byte has a running unary size bit: the most significant bit of \ + each byte tells is this is the last byte in the sequence (0) or if \ + there is more to read (1). The second most significant bit of the \ + first byte is reserved for the sign (positive if zero). Size and \ + sign bits ignored, data is then the binary representation of the \ + absolute value of the number in little endian order." + +let z_encoding = + Binary_schema.Obj { fields = [ Named_field ("Z.t", `Dynamic, Bytes) ] } + +let add_z_reference uf { descriptions } = + UF.add uf { name = z_reference_name ; + description = Some z_reference_description } ; + { descriptions = (z_reference_name, z_encoding) :: descriptions } + +let n_reference_name = "N.t" + +let n_reference_description = + "A variable length sequence of bytes, encoding a Zarith number. \ + Each byte has a running unary size bit: the most significant bit of \ + each byte tells is this is the last byte in the sequence (0) or if \ + there is more to read (1). Size bits ignored, data is then the binary \ + representation of the absolute value of the number in little endian order." + +let n_encoding = + Binary_schema.Obj { fields = [ Named_field ("N.t", `Dynamic, Bytes) ] } + +let add_n_reference uf { descriptions } = + UF.add uf { name = n_reference_name ; + description = Some n_reference_description } ; + { descriptions = (n_reference_name, n_encoding) :: descriptions } + +let describe (type x) ?toplevel_name (encoding : x Encoding.t) = + let open Encoding in + let uf = UF.empty () in + let uf_add_name name = + UF.add uf { name ; description = None } in + let add_reference name description { descriptions } = + { descriptions = (name, description) :: descriptions } in + let new_reference = + let x = ref ~-1 in + fun () -> + x := !x + 1 ; + let name = "X_" ^ string_of_int !x in + uf_add_name name ; + name in + let extract_dynamic : + type x. x Encoding.desc -> Binary_schema.field_descr list * x Encoding.desc = + function + | Dynamic_size { encoding } -> ([ Dynamic_field 1 ], encoding.encoding) + | enc -> ([], enc) in + let rec field_descr : + type a. recursives -> references -> + a Encoding.field -> Binary_schema.field_descr list * references = + fun recursives references -> function + | Req { name ; encoding = ({ encoding } as enc) } + | Dft { name ; encoding = ({ encoding } as enc) } -> + let (dynamics, field) = extract_dynamic encoding in + let (layout, references) = layout recursives references field in + (dynamics @ [ Named_field (name, classify enc, layout) ], references) + | Opt { kind = `Variable ; name ; encoding = { encoding } } -> + let (layout, references) = layout recursives references encoding in + ([ Named_field (name, `Variable, layout) ], references) + | Opt { kind = `Dynamic ; name ; encoding = { encoding } } -> + let (dynamics, field) = extract_dynamic encoding in + let (layout, references) = layout recursives references field in + (Binary_schema.Option_indicator_field name :: dynamics @ [ Named_field (name, `Dynamic, layout) ], references) + and obj fields = + Binary_schema.Obj { fields } + and union : + type a. recursives -> references -> Kind.t -> Binary_size.tag_size -> a case list -> string * references= + fun recursives references kind size cases -> + let cases = + List.sort (fun (t1, _) (t2, _) -> Compare.Int.compare t1 t2) @@ + TzList.filter_map + (function + | Case { tag = Json_only } -> None + | (Case { tag = Tag tag } as case) -> Some (tag, case)) + cases in + let tag_field = + Binary_schema.Named_field ("Tag", `Fixed (Binary_size.tag_size size), Int (size :> Binary_schema.integer_extended)) in + let (cases, references) = + List.fold_right + (fun (tag, Case case) (cases, references) -> + let fields, references = fields recursives references case.encoding.encoding in + ((tag, case.name, tag_field :: fields) :: cases, references)) + cases + ([], references) in + let name = new_reference () in + let references = + add_reference + name + (Cases { kind ; + tag_size = size ; + cases }) references in + (name, references) + and describe : type b. ?description:string -> name:string -> + recursives -> references -> b desc -> string * references = + fun ?description ~name recursives references encoding -> + let new_cannonical = { Binary_schema.name ; description } in + UF.add uf new_cannonical ; + let layout, references = layout recursives references encoding in + begin + match layout with + | Ref ref_name -> + UF.union uf ~existing:ref_name ~new_cannonical ; + (ref_name, references) + | layout -> + UF.add uf new_cannonical ; + (name, + add_reference name + (obj [ Anonymous_field (classify { encoding ; json_encoding = None }, layout) ]) + references) + end + and enum : type a. (a, _) Hashtbl.t -> a array -> _ = fun tbl encoding_array -> + (Binary_size.range_to_size ~minimum:0 ~maximum:(Array.length encoding_array), + List.map + (fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i))) + Utils.Infix.(0 -- ((Array.length encoding_array) - 1))) + and fields : + type b. recursives -> references -> + b Encoding.desc -> Binary_schema.fields * references = + fun recursives references -> function + | Obj field -> + field_descr recursives references field + | Objs { left ; right } -> + let (left_fields, references) = + fields recursives references left.encoding in + let (right_fields, references) = fields recursives references right.encoding in + (left_fields @ right_fields, references) + | Null -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) + | Empty -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) + | Ignore -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) + | Constant _ -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) + | Dynamic_size { encoding } -> + let (fields, refs) = fields recursives references encoding.encoding in + (Dynamic_field (List.length fields) :: fields, refs) + | Conv { encoding } -> + fields recursives references encoding.encoding + | Describe { id = name ; description ; encoding } -> + let (name, references) = describe ~name ?description recursives references encoding.encoding in + ([ Anonymous_field (classify encoding, Ref name) ], references) + | Splitted { encoding } -> + fields recursives references encoding.encoding + | Delayed func -> + fields recursives references (func ()).encoding + | List { encoding } -> + let (layout, references) = layout recursives references encoding in + ([ Anonymous_field (`Variable, Seq layout) ], + references) + | Array { encoding } -> + let (layout, references) = layout recursives references encoding in + ([ Anonymous_field (`Variable, Seq layout) ], + references) + | Bytes kind -> + ([ Anonymous_field ((kind :> Kind.t), Bytes) ], references) + | String kind -> + ([ Anonymous_field ((kind :> Kind.t), String) ], references) + | (String_enum (tbl, encoding_array) as encoding) -> + let size, cases = enum tbl encoding_array in + let name = new_reference () in + ([ Anonymous_field (classify { encoding ; json_encoding = None }, Ref name) ], + add_reference name (Int_enum { size ; cases }) references) + | Tup ({ encoding } as enc) -> + let (layout, references) = layout recursives references encoding in + ([ Anonymous_field (classify enc, layout) ], references) + | Tups { left ; right } -> + let (fields1, references) = fields recursives references left.encoding in + let (fields2, references) = fields recursives references right.encoding in + (fields1 @ fields2, references) + | Union { kind ; tag_size ; cases } -> + let name, references = union recursives references kind tag_size cases in + ([ Anonymous_field (kind, Ref name) ], references) + | (Mu { kind ; name ; description ; fix } as encoding) -> + let kind = (kind :> Kind.t) in + if List.mem name recursives + then ([ Anonymous_field (kind, Ref name) ], references) + else + let { encoding } = fix { encoding ; json_encoding = None } in + let (name, references) = describe ~name ?description (name :: recursives) references encoding in + ([ Anonymous_field (kind, Ref name) ], references) + | encoding -> + let layout, references = layout recursives references encoding in + ([ Anonymous_field (classify (make encoding), layout) ], references) + and layout : + type c. recursives -> references -> + c Encoding.desc -> Binary_schema.layout * references = + fun recursives references -> function + | Null -> (Zero_width, references) + | Empty -> (Zero_width, references) + | Ignore -> (Zero_width, references) + | Constant _ -> (Zero_width, references) + | Bool -> (Bool, references) + | Int8 -> (Int `Int8, references) + | Uint8 -> (Int `Uint8, references) + | Int16 -> (Int `Int16, references) + | Uint16 -> (Int `Uint16, references) + | Int31 -> (RangedInt (~-1073741824, 1073741823), references) + | Int32 -> (Int `Int32, references) + | Int64 -> (Int `Int64, references) + | N -> + (Ref n_reference_name, + add_n_reference uf references) + | Z -> + (Ref z_reference_name, + add_z_reference uf references) + | RangedInt { minimum ; maximum } -> + (RangedInt (minimum, maximum), references) + | RangedFloat { minimum ; maximum } -> + (RangedFloat (minimum, maximum), references) + | Float -> + (Float, references) + | Bytes _kind -> + (Bytes, references) + | String _kind -> + (String, references) + | String_enum (tbl, encoding_array) -> + let name = new_reference () in + let size, cases = enum tbl encoding_array in + let references = add_reference name (Int_enum { size ; cases }) references in + (Enum (size, name), references) + | Array data -> + let (descr, references) = layout recursives references data.encoding in + (Seq descr, references) + | List data -> + let layout, references = + layout recursives references data.encoding in + (Seq layout, references) + | (Obj _) as enc -> + let name = new_reference () in + let fields, references = fields recursives references enc in + let references = add_reference name (obj fields) references in + (Ref name, references) + | Objs { left ; right } -> + let name = new_reference () in + let fields1, references = fields recursives references left.encoding in + let fields2, references = fields recursives references right.encoding in + let references = add_reference name (obj (fields1 @ fields2)) references in + (Ref name, references) + | Tup { encoding } -> + layout recursives references encoding + | (Tups _ as descr) -> + let fields, references = fields recursives references descr in + let name = new_reference () in + let references = add_reference name (obj fields) references in + (Ref name, references) + | Union { kind ; tag_size ; cases } -> + let name, references = union recursives references kind tag_size cases in + (Ref name, references) + | Mu { name ; description ; fix } as encoding -> + if List.mem name recursives + then (Ref name, references) + else + let { encoding } = fix { encoding ; json_encoding = None } in + let (name, references) = describe ~name ?description (name :: recursives) references encoding in + (Ref name, references) + | Conv { encoding } -> + layout recursives references encoding.encoding + | Describe { id = name ; description ; encoding } -> + let name, references = + describe ~name ?description recursives references encoding.encoding in + (Ref name, references) + | Splitted { encoding } -> + layout recursives references encoding.encoding + | (Dynamic_size _) as encoding -> + let fields, references = fields recursives references encoding in + let name = new_reference () in + UF.add uf { name ; description = None } ; + (Ref name, add_reference name (obj fields) references) + | Check_size { encoding } -> + layout recursives references encoding.encoding + | Delayed func -> + layout recursives references (func ()).encoding in + let toplevel_name = Option.unopt ~default:"Toplevel encoding" toplevel_name in + uf_add_name toplevel_name ; + let fields, references = fields [] { descriptions = [] } encoding.encoding in + let rev_references = (toplevel_name, obj fields) :: references.descriptions in + let dedup_canonicalize = + let tbl : (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t = Hashtbl.create 100 in + let rec help prev_len acc = function + | [] -> + let fixedup = + List.map + (fun (desc, layout) -> (desc, fixup_references uf layout)) + acc in + if List.length fixedup = prev_len + then + List.map + (fun (name, layout) -> + (UF.find uf name, layout)) + fixedup + else + begin + Hashtbl.clear tbl ; + help (List.length fixedup) [] fixedup + end + | (name, layout) :: tl -> + match Hashtbl.find_opt tbl layout with + | None -> + let desc = UF.find uf name in + begin + Hashtbl.add tbl layout desc ; + help prev_len ((desc.name, layout) :: acc) tl + end + | Some original_desc -> + begin + UF.union uf + ~new_cannonical:original_desc + ~existing:name ; + help prev_len acc tl + end + in help 0 [] in + let filtered = + List.filter + (fun (name, encoding) -> + match encoding with + | Binary_schema.Obj { fields = [ Anonymous_field (_, Ref reference) ] } -> + UF.union uf ~new_cannonical:(UF.find uf name) ~existing:reference ; + false + | _ -> true) + rev_references in + dedup_canonicalize filtered diff --git a/src/lib_data_encoding/binary_description.mli b/src/lib_data_encoding/binary_description.mli new file mode 100644 index 000000000..332f4fd57 --- /dev/null +++ b/src/lib_data_encoding/binary_description.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val describe : ?toplevel_name:string -> 'a Encoding.t -> Binary_schema.t diff --git a/src/lib_data_encoding/binary_schema.ml b/src/lib_data_encoding/binary_schema.ml new file mode 100644 index 000000000..e2e896dab --- /dev/null +++ b/src/lib_data_encoding/binary_schema.ml @@ -0,0 +1,481 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Encoding + +type integer_extended = [ Binary_size.integer | `Int32 | `Int64 ] + +type field_descr = + | Named_field of string * Kind.t * layout + | Anonymous_field of Kind.t * layout + | Dynamic_field of int + | Option_indicator_field of string + +and layout = + | Zero_width + | Int of integer_extended + | Bool + | RangedInt of int * int + | RangedFloat of float * float + | Float + | Bytes + | String + | Enum of Binary_size.integer * string + | Seq of layout (* For arrays and lists *) + | Ref of string + +and fields = field_descr list + +and toplevel_encoding = + | Obj of { fields : fields } + | Cases of { kind : Kind.t ; + tag_size : Binary_size.tag_size ; + cases : (int * string option * fields) list } + | Int_enum of { size : Binary_size.integer ; + cases : (int * string) list } + +and description = + { name : string ; + description : string option } + +type t = (description * toplevel_encoding) list + +module Printer = struct + + type table = + { title : string ; + description : string option ; + headers : string list ; + body : string list list } + + type print_structure = + | Table of table + | Union of string * string option * Binary_size.tag_size * table list + + let pp_kind ppf = function + | `Fixed size -> Format.fprintf ppf "%d byte%s" size (if size = 1 then "" else "s") + | `Variable -> Format.fprintf ppf "Variable size" + | `Dynamic -> Format.fprintf ppf "Determined from data" + + let pp_int ppf (int : integer_extended) = + Format.fprintf ppf "%s" + begin + match int with + | `Int16 -> "16 bit Signed Integer" + | `Int31 -> "32 bit Signed Integer in the range [2^30, 2^30-1]" + | `Uint30 -> "32 bit Signed Integer in the range [0, 2^30-1]" + | `Int32 -> "32 bit Signed Integer" + | `Int64 -> "64 bit Signed Integer" + | `Int8 -> "8 bit Signed Integer" + | `Uint16 -> "16 bit Unsigned Integer" + | `Uint8 -> "8 bit Unsigned Integer" + end + + let rec pp_layout ppf = function + | Zero_width -> + Format.fprintf ppf "Zero width data, not actually present in the encoding" + | Int integer -> + Format.fprintf ppf "%a" pp_int integer + | Bool -> + Format.fprintf ppf "8 bit Signed Integer, with 0 for false and 255 for true" + | RangedInt (minimum, maximum) -> + Format.fprintf ppf "%a in the range %d to %d" + pp_int ((Binary_size.range_to_size ~minimum ~maximum) :> integer_extended) minimum maximum + | RangedFloat (minimum, maximum) -> + Format.fprintf ppf + "Double precision (8 byte) floating point number in the range %f to %f" + minimum maximum + | Float -> + Format.fprintf ppf "Double precision (8 byte) floating point number" + | Bytes -> + Format.fprintf ppf "Bytes" + | String -> + Format.fprintf ppf "String" + | Ref reference -> + Format.fprintf ppf "%s" reference + | Enum (size, reference) -> + Format.fprintf ppf "%a encoding an enumeration (see %s)" + pp_int (size :> integer_extended) + reference + | Seq (Ref reference) -> Format.fprintf ppf "Sequence of %s" reference + | Seq data -> Format.fprintf ppf "Sequence of %a" pp_layout data + + + let binary_table_headers = [ "Name" ; "Kind" ; "Data" ] + let enum_headers = [ "Case number" ; "Encoded string" ] + + let pp_tag_size ppf tag = + Format.fprintf ppf "%s" @@ + match tag with + | `Uint8 -> "8 bit" + | `Uint16 -> "16 bit" + + let field_descr () = + let reference = ref 0 in + let string_of_layout = Format.asprintf "%a" pp_layout in + let anon_num () = + let value = !reference in + reference := value + 1; + string_of_int value in + function + | Named_field (name, kind, desc) -> + [ name ; Format.asprintf "%a" pp_kind kind ; string_of_layout desc ] + | Dynamic_field i -> + [ Format.asprintf "Size of next %d fields" i ; + Format.asprintf "%a" pp_kind (`Fixed 4) ; string_of_layout (Int `Int32) ] + | Anonymous_field (kind, desc) -> + [ "Unnamed field " ^ anon_num () ; + Format.asprintf "%a" pp_kind kind ; + string_of_layout desc ] + | Option_indicator_field name -> + [ "Presence of " ^ name ; + Format.asprintf "%a" pp_kind (`Fixed 1) ; + "0 if not present and 1 if present" ] + + let toplevel ({ name ; description }, encoding) = + match encoding with + | Obj { fields } -> + Table { title = Format.asprintf "%s" name ; + description ; + headers = binary_table_headers ; + body = List.map (field_descr ()) fields } + | Cases { kind ; tag_size ; cases } -> + Union (Format.asprintf "%s (%a, %a tag)" name pp_kind kind pp_tag_size tag_size, + description, tag_size, + List.map + (fun (tag, name, fields) -> + { title = + begin + match name with + | Some name -> Format.asprintf "%s (tag %d)" name tag + | None -> Format.asprintf "Tag %d" tag + end; + description = None ; + headers = binary_table_headers ; + body = List.map (field_descr ()) fields }) + cases) + | Int_enum { size ; cases } -> + Table + { title = Format.asprintf "Enum %s (%a):" name pp_int (size :> integer_extended) ; + description = None; + headers = enum_headers ; + body = List.map (fun (num, str) -> [ string_of_int num ; str ]) cases } + + let to_print_ast encodings = + List.map toplevel encodings + + let rec pad char ppf = function + | 0 -> () + | n -> + Format.pp_print_char ppf char ; + pad char ppf (n - 1) + + let pp_table ppf (level, { title ; description ; headers ; body }) = + let max_widths = + List.fold_left (List.map2 (fun len str -> max (String.length str) len)) + (List.map String.length headers) + body in + let pp_row pad_char ppf = + Format.fprintf ppf "|%a" + (fun ppf -> + List.iter2 + (fun width str -> Format.fprintf ppf " %s%a |" str (pad pad_char) (width - (String.length str))) + max_widths) in + let pp_option_nl ppf = + Option.iter ~f:(Format.fprintf ppf "@,%s") in + Format.fprintf ppf "@[%a %s%a@,@,%a@,%a@,%a@,@]" + (pad '#') level + title + pp_option_nl description + (pp_row ' ') headers + (pp_row '-') (List.map (fun _ -> "-") headers) + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,") + (pp_row ' ')) + body + + let pp_print_structure ?(initial_level=0) ppf = function + | Table table -> pp_table ppf (1 + initial_level, table) + | Union (name, description, _tag_size, tables) -> + Format.fprintf ppf "@[%a %s:%a@,%a@]" + (pad '#') (initial_level + 1) + name + (fun ppf -> function + | None -> () + | Some description -> + Format.fprintf ppf "@,%s" description) + description + (fun ppf -> Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,") + pp_table + ppf) + (List.map (fun x -> (initial_level + 2, x)) tables) + + let pp ppf descrs = + Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,") + (pp_print_structure ~initial_level:0) + ppf + (to_print_ast descrs) + +end + +module Encoding = struct + + let description_encoding = + conv + (fun { name ; description } -> (name, description)) + (fun (name, description) -> { name ; description }) + (obj2 + (req "name" string) + (opt "description" string)) + + + let integer_cases = + [ ("Int16", `Int16) ; + ("Int8", `Int8) ; + ("Uint16", `Uint16) ; + ("Uint8", `Uint8) ] + + let integer_encoding : Binary_size.integer encoding = + string_enum integer_cases + + let integer_extended_encoding = + string_enum + (("Int64", `Int64) :: + ("Int32", `Int32) :: + integer_cases) + + let layout_encoding = + mu "layout" + (fun layout -> + union [ + case + ~name:"Zero_width" + (Tag 0) + (obj1 + (req "kind" (constant "Zero_width"))) + (function + | Zero_width -> Some () + | _ -> None) + (fun () -> Zero_width) ; + case ~name:"Int" + (Tag 1) + (obj2 + (req "size" integer_extended_encoding) + (req "kind" (constant "Int"))) + (function + | Int integer -> Some (integer, ()) + | _ -> None) + (fun (integer, _)-> Int integer) ; + case ~name:"Bool" + (Tag 2) + (obj1 (req "kind" (constant "Bool"))) + (function + | Bool -> Some () + | _ -> None) + (fun () -> Bool) ; + case ~name:"RangedInt" + (Tag 3) + (obj3 + (req "min" int31) + (req "max" int31) + (req "kind" (constant "RangedInt"))) + (function + | RangedInt (min, max) -> Some (min, max, ()) + | _ -> None) + (fun (min, max, _) -> RangedInt (min, max)) ; + case ~name:"RangedFloat" + (Tag 4) + (obj3 + (req "min" float) + (req "max" float) + (req "kind" (constant "RangedFloat"))) + (function + | RangedFloat (min, max) -> Some (min, max, ()) + | _ -> None) + (fun (min, max, ()) -> RangedFloat (min, max)) ; + case ~name:"Float" + (Tag 5) + (obj1 (req "kind" (constant "Float"))) + (function + | Float -> Some () + | _ -> None) + (fun () -> Float) ; + case ~name:"Bytes" + (Tag 6) + (obj1 (req "kind" (constant "Bytes"))) + (function + | Bytes -> Some () + | _ -> None) + (fun () -> Bytes) ; + case ~name:"String" + (Tag 7) + (obj1 (req "kind" (constant "String"))) + (function + | String -> Some () + | _ -> None) + (fun () -> String) ; + case ~name:"Enum" + (Tag 8) + (obj3 + (req "size" integer_encoding) + (req "reference" string) + (req "kind" (constant "Enum"))) + (function + | Enum (size, cases) -> Some (size, cases, ()) + | _ -> None) + (fun (size, cases, _) -> Enum (size, cases)) ; + case ~name:"Seq" + (Tag 9) + (obj2 + (req "layout" layout) + (req "kind" (constant "Seq"))) + (function + | Seq layout -> Some (layout, ()) + | _ -> None) + (fun (layout, ()) -> Seq layout) ; + case ~name:"Ref" + (Tag 10) + (obj2 + (req "name" string) + (req "kind" (constant "Float"))) + (function + | Ref layout -> Some (layout, ()) + | _ -> None) + (fun (name, ()) -> Ref name) + ]) + + let kind_enum_cases = + (fun () -> + [ case ~name:"Dynamic" + (Tag 0) + (obj1 (req "kind" (constant "Dynamic"))) + (function `Dynamic -> Some () + | _ -> None) + (fun () -> `Dynamic) ; + case ~name:"Variable" + (Tag 1) + (obj1 (req "kind" (constant "Variable"))) + (function `Variable -> Some () + | _ -> None) + (fun () -> `Variable) ]) + + let kind_enum_encoding = + def "schema.kind.enum" @@ union (kind_enum_cases ()) + + let kind_t_encoding = + def "schema.kind" @@ + union + ((case ~name:"Fixed" + (Tag 2) + (obj2 + (req "size" int31) + (req "kind" (constant "Float"))) + (function `Fixed n -> Some (n, ()) + | _ -> None) + (fun (n, _) -> `Fixed n)) :: (kind_enum_cases ())) + + let field_descr_encoding = + let dynamic_layout_encoding = dynamic_size layout_encoding in + def "schema.field" @@ + union [ + case ~name:"Named_field" + (Tag 0) + (obj4 + (req "name" string) + (req "layout" dynamic_layout_encoding) + (req "data_kind" kind_t_encoding) + (req "kind" (constant "named"))) + (function Named_field (name, kind, layout) -> Some (name, layout, kind, ()) + | _ -> None) + (fun (name, kind, layout, _) -> Named_field (name, layout, kind)) ; + case ~name:"Anonymous_field" + (Tag 1) + (obj3 + (req "layout" dynamic_layout_encoding) + (req "kind" (constant "anon")) + (req "data_kind" kind_t_encoding)) + (function Anonymous_field (kind, layout) -> Some (layout, (), kind) + | _ -> None) + (fun (kind, _, layout) -> Anonymous_field (layout, kind)) ; + case ~name:"Dynamic_field" + (Tag 2) + (obj2 + (req "kind" (constant "dyn")) + (req "num_fields" int31)) + (function Dynamic_field i -> Some ((), i) + | _ -> None) + (fun ((), i) -> Dynamic_field i) ; + case ~name:"Option_indicator_field" + (Tag 3) + (obj2 + (req "kind" (constant "option_indicator")) + (req "name" string)) + (function Option_indicator_field s -> Some ((), s) + | _ -> None) + (fun ((), s) -> Option_indicator_field s) + ] + + let tag_size_encoding = + string_enum + [("Uint16", `Uint16) ; + ("Uint8", `Uint8) ] + + let binary_description_encoding = + union [ + case ~name:"Obj" + (Tag 0) + (obj1 + (req "fields" (list (dynamic_size field_descr_encoding)))) + (function + | Obj { fields } -> Some (fields) + | _ -> None) + (fun (fields) -> Obj { fields }) ; + case ~name:"Cases" + (Tag 1) + (obj3 + (req "tag_size" tag_size_encoding) + (req "kind" (dynamic_size kind_t_encoding)) + (req "cases" + (list + (def "union case" @@ + conv + (fun (tag, name, fields) -> (tag, fields, name)) + (fun (tag, fields, name) -> (tag, name, fields)) @@ + obj3 + (req "tag" int31) + (req "fields" (list (dynamic_size field_descr_encoding))) + (opt "name" string))))) + (function + | Cases { kind ; tag_size ; cases } -> + Some (tag_size, kind, cases) + | _ -> None) + (fun (tag_size, kind, cases) -> + Cases { kind ; tag_size ; cases }) ; + case ~name:"Int_enum" + (Tag 2) + (obj2 + (req "size" integer_encoding) + (req "cases" (list (tup2 int31 string)))) + (function Int_enum { size ; cases } -> Some (size, cases) + | _ -> None) + (fun (size, cases) -> Int_enum { size ; cases }) + ] + + let encoding = + list + (obj2 + (req "description" description_encoding) + (req "encoding" binary_description_encoding)) + +end + +let encoding = Encoding.encoding +let pp = Printer.pp diff --git a/src/lib_data_encoding/binary_schema.mli b/src/lib_data_encoding/binary_schema.mli new file mode 100644 index 000000000..aac95d120 --- /dev/null +++ b/src/lib_data_encoding/binary_schema.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** This is for use *within* the data encoding library only. *) + +type integer_extended = [ Binary_size.integer | `Int32 | `Int64 ] + +type field_descr = + | Named_field of string * Encoding.Kind.t * layout + | Anonymous_field of Encoding.Kind.t * layout + | Dynamic_field of int + | Option_indicator_field of string + +and layout = + | Zero_width + | Int of integer_extended + | Bool + | RangedInt of int * int + | RangedFloat of float * float + | Float + | Bytes + | String + | Enum of Binary_size.integer * string + | Seq of layout (* For arrays and lists *) + | Ref of string + +and fields = field_descr list + +and toplevel_encoding = + | Obj of { fields : fields } + | Cases of { kind : Encoding.Kind.t ; + tag_size : Binary_size.tag_size ; + cases : (int * string option * fields) list } + | Int_enum of { size : Binary_size.integer ; + cases : (int * string) list } + +and description = + { name : string ; + description : string option } + +type t = (description * toplevel_encoding) list + +module Printer : sig + val pp_layout : Format.formatter -> layout -> unit +end + +val pp: Format.formatter -> t -> unit +val encoding: t Encoding.t diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index 4b019aa22..00e82eeeb 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -109,12 +109,14 @@ include Encoding module Json = Json module Bson = Bson +module Binary_schema = Binary_schema module Binary = struct include Binary_error include Binary_length include Binary_writer include Binary_reader include Binary_stream_reader + let describe = Binary_description.describe end type json = Json.t diff --git a/src/lib_data_encoding/data_encoding.mli b/src/lib_data_encoding/data_encoding.mli index 4a07877d6..a695557cd 100644 --- a/src/lib_data_encoding/data_encoding.mli +++ b/src/lib_data_encoding/data_encoding.mli @@ -591,6 +591,12 @@ module Bson: sig end +module Binary_schema : sig + type t + val pp: Format.formatter -> t -> unit + val encoding: t Encoding.t +end + module Binary: sig (** All the errors that might be returned while reading a binary value *) @@ -672,6 +678,8 @@ module Binary: sig it raises [Write_error] instead of return [None] in case of error. *) val to_bytes_exn : 'a Encoding.t -> 'a -> MBytes.t + val describe : ?toplevel_name:string -> 'a Encoding.t -> Binary_schema.t + end type json = Json.t diff --git a/src/lib_rpc/RPC_description.mli b/src/lib_rpc/RPC_description.mli index 061606287..7f8d73628 100644 --- a/src/lib_rpc/RPC_description.mli +++ b/src/lib_rpc/RPC_description.mli @@ -15,5 +15,5 @@ val describe: #RPC_context.simple -> ?recurse:bool -> string list -> - Json_schema.schema directory tzresult Lwt.t + RPC_encoding.schema directory tzresult Lwt.t diff --git a/src/lib_rpc/RPC_encoding.ml b/src/lib_rpc/RPC_encoding.ml index 341d11713..2b67799cb 100644 --- a/src/lib_rpc/RPC_encoding.ml +++ b/src/lib_rpc/RPC_encoding.ml @@ -8,11 +8,19 @@ (**************************************************************************) type 'a t = 'a Data_encoding.t -type schema = Data_encoding.json_schema +type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t let unit = Data_encoding.empty let untyped = Data_encoding.(obj1 (req "untyped" string)) let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t -let schema = Data_encoding.Json.schema +let schema t = + (Data_encoding.Json.schema t, + Data_encoding.Binary.describe t) + +let schema_encoding = + let open Data_encoding in + obj2 + (req "json_schema" json_schema) + (req "binary_schema" Data_encoding.Binary_schema.encoding) module StringMap = Resto.StringMap @@ -97,9 +105,9 @@ let service_descr_encoding = (req "path" (list path_item_encoding)) (opt "description" string) (req "query" (list query_item_encoding)) - (opt "input" json_schema) - (req "output" json_schema) - (req "erro" json_schema)) + (opt "input" schema_encoding) + (req "output" schema_encoding) + (req "error" schema_encoding)) let directory_descr_encoding = let open Data_encoding in diff --git a/src/lib_rpc/RPC_encoding.mli b/src/lib_rpc/RPC_encoding.mli index c583023b0..631ae9912 100644 --- a/src/lib_rpc/RPC_encoding.mli +++ b/src/lib_rpc/RPC_encoding.mli @@ -7,6 +7,8 @@ (* *) (**************************************************************************) -include Resto.ENCODING with type 'a t = 'a Data_encoding.t - and type schema = Data_encoding.json_schema +type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t + +include Resto.ENCODING with type 'a t = 'a Data_encoding.t + and type schema := schema diff --git a/src/lib_rpc/RPC_service.mli b/src/lib_rpc/RPC_service.mli index 841826035..7e03eff60 100644 --- a/src/lib_rpc/RPC_service.mli +++ b/src/lib_rpc/RPC_service.mli @@ -76,7 +76,7 @@ val put_service: val description_service: ([ `GET ], unit, unit * string list, Resto.Description.request, - unit, Json_schema.schema Resto.Description.directory) service + unit, RPC_encoding.schema Resto.Description.directory) service val error_service: ([ `GET ], unit, unit, unit, unit, Json_schema.schema) service