balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Data_encoding: binary description printing

Browse Source
This commit is contained in:
Milo Davis 2018-02-03 14:48:08 -05:00 committed by Benjamin Canou
parent 4c03952e43
commit 0a88f1887c
12 changed files with 1008 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
docs/doc_gen/rpcs/rpc_doc.ml
View File

@ -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

29
src/bin_client/client_rpc_commands.ml
View File

@ -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) =
@[<v 2>Input format:@,%a@]@,\
@[<v 2>Output format:@,%a@]@,\
@]"
Json_schema.pp input
Json_schema.pp output >>= fun () ->
pp input
pp output >>= fun () ->
return ()
| { input = None ; output } ->
cctxt#message
"@[<v 0>\
@[<v 2>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."

412
src/lib_data_encoding/binary_description.ml Normal file
View File

@ -0,0 +1,412 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 "@[<v 2>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

10
src/lib_data_encoding/binary_description.mli Normal file
View File

@ -0,0 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val describe : ?toplevel_name:string -> 'a Encoding.t -> Binary_schema.t

481
src/lib_data_encoding/binary_schema.ml Normal file
View File

@ -0,0 +1,481 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 "@[<v 0>%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 "@[<v 0>%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

54
src/lib_data_encoding/binary_schema.mli Normal file
View File

@ -0,0 +1,54 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

2
src/lib_data_encoding/data_encoding.ml
View File

@ -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

8
src/lib_data_encoding/data_encoding.mli
View File

@ -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

2
src/lib_rpc/RPC_description.mli
View File

@ -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

18
src/lib_rpc/RPC_encoding.ml
View File

@ -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

6
src/lib_rpc/RPC_encoding.mli
View File

@ -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

2
src/lib_rpc/RPC_service.mli
View File

@ -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