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

Data_encoding: merge def and describe

Browse Source
This commit is contained in:
Grégoire Henry 2018-05-29 14:57:59 +02:00
parent 2164782fe0
commit b2e6001007
32 changed files with 304 additions and 378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
src/bin_node/node_config_file.ml
View File

@ -206,61 +206,50 @@ let limit : P2p.limits Data_encoding.t =
(merge_objs
(obj10
(dft "connection-timeout"
(Data_encoding.describe
~description: "Delay acceptable when initiating a \
connection to a new peer, in seconds."
float) default_p2p_limits.authentication_timeout)
float default_p2p_limits.authentication_timeout)
(dft "authentication-timeout"
(Data_encoding.describe
~description: "Delay granted to a peer to perform authentication, \
in seconds."
float) default_p2p_limits.authentication_timeout)
float default_p2p_limits.authentication_timeout)
(dft "min-connections"
(Data_encoding.describe
~description: "Strict minimum number of connections (triggers an \
urgent maintenance)."
uint16)
uint16
default_p2p_limits.min_connections)
(dft "expected-connections"
(Data_encoding.describe
~description: "Targeted number of connections to reach when \
bootstraping / maintaining."
uint16)
uint16
default_p2p_limits.expected_connections)
(dft "max-connections"
(Data_encoding.describe
~description: "Maximum number of connections (exceeding peers are \
disconnected)."
uint16)
uint16
default_p2p_limits.max_connections)
(dft "backlog"
(Data_encoding.describe
~description: "Number above which pending incoming connections are \
immediately rejected."
uint8)
uint8
default_p2p_limits.backlog)
(dft "max-incoming-connections"
(Data_encoding.describe
~description: "Number above which pending incoming connections are \
immediately rejected."
uint8)
uint8
default_p2p_limits.max_incoming_connections)
(opt "max-download-speed"
(Data_encoding.describe
~description: "Max download speeds in KiB/s."
int31))
int31)
(opt "max-upload-speed"
(Data_encoding.describe
~description: "Max upload speeds in KiB/s."
int31))
int31)
(dft "swap-linger" float default_p2p_limits.swap_linger))
(obj10
(opt "binary-chunks-size" uint8)
(dft "read-buffer-size"
(Data_encoding.describe
~description: "Size of the buffer passed to read(2)."
int31)
int31
default_p2p_limits.read_buffer_size)
(opt "read-queue-size" int31)
(opt "write-queue-size" int31)
@ -276,9 +265,8 @@ let limit : P2p.limits Data_encoding.t =
(obj2
(opt "max_known_peer_ids" (tup2 uint16 uint16))
(dft "greylist-timeout"
(Data_encoding.describe
~description: "GC delay for the greylists tables, in seconds."
int31) default_p2p_limits.greylist_timeout)
int31 default_p2p_limits.greylist_timeout)
))
@ -295,30 +283,26 @@ let p2p =
listen_addr ; closed ; limits })
(obj5
(dft "expected-proof-of-work"
(Data_encoding.describe
~description: "Floating point number between 0 and 256 that represents a \
difficulty, 24 signifies for example that at least 24 leading \
zeroes are expected in the hash."
float) default_p2p.expected_pow)
float default_p2p.expected_pow)
(dft "bootstrap-peers"
(Data_encoding.describe
~description: "List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. \
If the port is not specified, default port 9732 will be assumed."
(list string)) default_p2p.bootstrap_peers)
(list string) default_p2p.bootstrap_peers)
(opt "listen-addr"
(Data_encoding.describe ~description: "Host to listen to. If the port is not \
~description: "Host to listen to. If the port is not \
specified, the default port 8732 will be \
assumed."
string))
string)
(dft "closed"
(Data_encoding.describe
~description: "Specify if the network is closed or not. A closed network allows \
only peers listed in 'bootstrap-peers'."
bool) false)
bool false)
(dft "limits"
(Data_encoding.describe
~description: "Network limits"
limit) default_p2p_limits)
limit default_p2p_limits)
)
let rpc : rpc Data_encoding.t =
@ -338,28 +322,23 @@ let rpc : rpc Data_encoding.t =
{ listen_addr ; cors_origins ; cors_headers ; tls })
(obj5
(opt "listen-addr"
(Data_encoding.describe
~description: "Host to listen to. If the port is not specified, \
the default port 8732 will be assumed."
string))
string)
(dft "cors-origin"
(Data_encoding.describe
~description: "Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)) default_rpc.cors_origins)
(list string) default_rpc.cors_origins)
(dft "cors-headers"
(Data_encoding.describe
~description: "Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)) default_rpc.cors_headers)
(list string) default_rpc.cors_headers)
(opt "crt"
(Data_encoding.describe
~description: "Certificate file (necessary when TLS is used)."
string))
string)
(opt "key"
(Data_encoding.describe
~description: "Key file (necessary when TLS is used)."
string))
string)
)
let level_encoding =
@ -392,29 +371,25 @@ let log =
{ output ; default_level ; rules ; template })
(obj4
(dft "output"
(Data_encoding.describe
~description: "Output for the logging function. Either 'stdout', \
'stderr' or the name of a log file ."
Logging_unix.Output.encoding) default_log.output)
Logging_unix.Output.encoding default_log.output)
(dft "level"
(Data_encoding.describe
~description: "Verbosity level: one of 'fatal', 'error', 'warn',\
'notice', 'info', 'debug'."
level_encoding) default_log.default_level)
level_encoding default_log.default_level)
(opt "rules"
(Data_encoding.describe
~description: "Fine-grained logging instructions. Same format as \
described in `tezos-node run --help`, DEBUG section. \
In the example below, sections 'p2p' and all sections \
starting by 'client' will have their messages logged \
up to the debug level, whereas the rest of log sections \
will be logged up to the notice level."
string))
string)
(dft "template"
(Data_encoding.describe
~description: "Format for the log file, see \
http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
string) default_log.template)
string default_log.template)
)
@ -508,11 +483,10 @@ let chain_validator_limits_encoding =
(merge_objs
(obj1
(dft "bootstrap_threshold"
(Data_encoding.describe
~description:
"Set the number of peers with whom a chain synchronization must \
be completed to bootstrap the node."
uint8)
uint8
default_shell.chain_validator_limits.bootstrap_threshold))
(worker_limits_encoding
default_shell.chain_validator_limits.worker_limits.backlog_size
@ -547,24 +521,19 @@ let encoding =
{ data_dir ; rpc ; p2p ; log ; shell })
(obj5
(dft "data-dir"
(Data_encoding.describe
~description: "Location of the data dir on disk."
string) default_data_dir)
string default_data_dir)
(dft "rpc"
(Data_encoding.describe
~description: "Configuration of rpc parameters"
rpc) default_rpc)
rpc default_rpc)
(req "p2p"
(Data_encoding.describe
~description: "Configuration of network parameters" p2p))
~description: "Configuration of network parameters" p2p)
(dft "log"
(Data_encoding.describe
~description: "Configuration of network parameters"
log) default_log)
log default_log)
(dft "shell"
(Data_encoding.describe
~description: "Configuration of network parameters"
shell) default_shell))
shell default_shell))
let read fp =
if Sys.file_exists fp then begin

3
src/lib_base/fitness.ml
View File

@ -52,7 +52,8 @@ let rec pp fmt = function
let encoding =
let open Data_encoding in
describe ~title: "Tezos block fitness"
def "fitness"
~title: "Tezos block fitness"
(list bytes)
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

2
src/lib_base/test_chain_status.ml
View File

@ -22,7 +22,7 @@ type t =
let encoding =
let open Data_encoding in
describe ~title:"Test chain status" @@
def "test_chain_status" @@
union [
case (Tag 0) ~name:"Not_running"
(obj1 (req "status" (constant "not_running")))

5
src/lib_base/time.ml
View File

@ -78,8 +78,7 @@ module T = struct
let rfc_encoding =
let open Data_encoding in
def
"timestamp" @@
describe
"timestamp.rfc"
~title:
"RFC 3339 formatted timestamp"
~description:
@ -93,7 +92,7 @@ module T = struct
let encoding =
let open Data_encoding in
describe ~title:"timestamp" @@
def "timestamp" @@
splitted
~binary: int64
~json:

3
src/lib_crypto/helpers.ml
View File

@ -103,7 +103,8 @@ module MakeEncoder(H : sig
~binary:
H.raw_encoding
~json:
(describe ~title: (H.title ^ " (Base58Check-encoded)") @@
(def H.title
~title: (H.title ^ " (Base58Check-encoded)") @@
conv
H.to_b58check
(Data_encoding.Json.wrap_error H.of_b58check_exn)

3
src/lib_crypto/signature.ml
View File

@ -47,6 +47,7 @@ module Public_key_hash = struct
let raw_encoding =
let open Data_encoding in
def "public_key_hash" ~description:title @@
union [
case (Tag 0) Ed25519.Public_key_hash.encoding
(function Ed25519 x -> Some x | _ -> None)
@ -230,6 +231,7 @@ module Public_key = struct
let title = title
let raw_encoding =
let open Data_encoding in
def "public_key" ~description:title @@
union [
case (Tag 0) Ed25519.Public_key.encoding
(function Ed25519 x -> Some x | _ -> None)
@ -312,6 +314,7 @@ module Secret_key = struct
let title = title
let raw_encoding =
let open Data_encoding in
def "secret_key" ~description:title @@
union [
case (Tag 0) Ed25519.Secret_key.encoding
(function Ed25519 x -> Some x | _ -> None)

5
src/lib_data_encoding/binary_length.ml
View File

@ -62,7 +62,7 @@ let rec length : type x. x Encoding.t -> x -> int =
let tag_size = Binary_size.tag_size sz in
tag_size + length e value in
length_case cases
| Mu (`Dynamic, _name, self) ->
| Mu (`Dynamic, _name, _, _, self) ->
length (self e) value
| Obj (Opt { kind = `Dynamic ; encoding = e }) -> begin
match value with
@ -103,7 +103,7 @@ let rec length : type x. x Encoding.t -> x -> int =
let tag_size = Binary_size.tag_size sz in
tag_size + length e value in
length_case cases
| Mu (`Variable, _name, self) ->
| Mu (`Variable, _name, _, _, self) ->
length (self e) value
(* Recursive*)
| Obj (Req { encoding = e }) -> length e value
@ -112,7 +112,6 @@ let rec length : type x. x Encoding.t -> x -> int =
| Conv { encoding = e ; proj } ->
length e (proj value)
| Describe { encoding = e } -> length e value
| Def { encoding = e } -> length e value
| Splitted { encoding = e } -> length e value
| Dynamic_size { kind ; encoding = e } ->
let length = length e value in

3
src/lib_data_encoding/binary_reader.ml
View File

@ -271,9 +271,8 @@ let rec read_rec : type ret. ret Encoding.t -> state -> ret
state.allowed_bytes <- allowed_bytes ;
v
| Describe { encoding = e } -> read_rec e state
| Def { encoding = e } -> read_rec e state
| Splitted { encoding = e } -> read_rec e state
| Mu (_, _, self) -> read_rec (self e) state
| Mu (_, _, _, _, self) -> read_rec (self e) state
| Delayed f -> read_rec (f ()) state

3
src/lib_data_encoding/binary_stream_reader.ml
View File

@ -340,9 +340,8 @@ let rec read_rec
Some (old_limit - read) in
k (v, { state with allowed_bytes })
| Describe { encoding = e } -> read_rec e state k
| Def { encoding = e } -> read_rec e state k
| Splitted { encoding = e } -> read_rec e state k
| Mu (_, _, self) -> read_rec (self e) state k
| Mu (_, _, _, _, self) -> read_rec (self e) state k
| Delayed f -> read_rec (f ()) state k
and remaining_bytes { remaining_bytes } =

3
src/lib_data_encoding/binary_writer.ml
View File

@ -272,9 +272,8 @@ let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
| Check_size { limit ; encoding = e } ->
write_with_limit limit e state value
| Describe { encoding = e } -> write_rec e state value
| Def { encoding = e } -> write_rec e state value
| Splitted { encoding = e } -> write_rec e state value
| Mu (_, _, self) -> write_rec (self e) state value
| Mu (_, _, _, _, self) -> write_rec (self e) state value
| Delayed f -> write_rec (f ()) state value
and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit =

15
src/lib_data_encoding/data_encoding.mli
View File

@ -447,18 +447,21 @@ module Encoding: sig
val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding
(** Combinator for recursive encodings. *)
val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
val mu :
string ->
?title: string ->
?description: string ->
('a encoding -> 'a encoding) -> 'a encoding
(** {3 Documenting descriptors} *)
(** Add documentation to an encoding. *)
val describe :
(** Give a name to an encoding and optionnaly
add documentation to an encoding. *)
val def :
string ->
?title:string -> ?description:string ->
't encoding ->'t encoding
(** Give a name to an encoding. *)
val def : string -> 'a encoding -> 'a encoding
(** See {!lazy_encoding} below.*)
type 'a lazy_t

58
src/lib_data_encoding/encoding.ml
View File

@ -91,18 +91,17 @@ type 'a desc =
| Tup : 'a t -> 'a desc
| Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc
| Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc
| Mu : Kind.enum * string * ('a t -> 'a t) -> 'a desc
| Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc
| Conv :
{ proj : ('a -> 'b) ;
inj : ('b -> 'a) ;
encoding : 'b t ;
schema : Json_schema.schema option } -> 'a desc
| Describe :
{ title : string option ;
{ id : string ;
title : string option ;
description : string option ;
encoding : 'a t } -> 'a desc
| Def : { name : string ;
encoding : 'a t } -> 'a desc
| Splitted :
{ encoding : 'a t ;
json_encoding : 'a Json_encoding.encoding ;
@ -116,14 +115,20 @@ type 'a desc =
and _ field =
| Req : { name: string ;
encoding: 'a t ;
title: string option ;
description: string option ;
} -> 'a field
| Opt : { name: string ;
kind: Kind.enum ;
encoding: 'a t ;
title: string option ;
description: string option ;
} -> 'a option field
| Dft : { name: string ;
encoding: 'a t ;
default: 'a ;
title: string option ;
description: string option ;
} -> 'a field
and 'a case =
@ -169,7 +174,7 @@ let rec classify : type a. a t -> Kind.t = fun e ->
| Objs (kind, _, _) -> kind
| Tups (kind, _, _) -> kind
| Union (kind, _, _) -> (kind :> Kind.t)
| Mu (kind, _, _) -> (kind :> Kind.t)
| Mu (kind, _, _, _ , _) -> (kind :> Kind.t)
(* Variable *)
| Ignore -> `Fixed 0
| Array _ -> `Variable
@ -180,7 +185,6 @@ let rec classify : type a. a t -> Kind.t = fun e ->
| Tup encoding -> classify encoding
| Conv { encoding } -> classify encoding
| Describe { encoding } -> classify encoding
| Def { encoding } -> classify encoding
| Splitted { encoding } -> classify encoding
| Dynamic_size _ -> `Dynamic
| Check_size { encoding } -> classify encoding
@ -241,11 +245,10 @@ let rec is_zeroable: type t. t encoding -> bool = fun e ->
| Tups (_, e1, e2) -> is_zeroable e1 && is_zeroable e2
| Union (_, _, _) -> false (* includes a tag *)
(* other recursive cases: truth propagates *)
| Mu (`Dynamic, _, _) -> false (* size prefix *)
| Mu (`Variable, _, f) -> is_zeroable (f e)
| Mu (`Dynamic, _, _, _ ,_) -> false (* size prefix *)
| Mu (`Variable, _, _, _, f) -> is_zeroable (f e)
| Conv { encoding } -> is_zeroable encoding
| Describe { encoding } -> is_zeroable encoding
| Def { encoding } -> is_zeroable encoding
| Splitted { encoding } -> is_zeroable encoding
| Check_size { encoding } -> is_zeroable encoding
(* Unscrutable: true by default *)
@ -331,29 +334,21 @@ let string_enum = function
let conv proj inj ?schema encoding =
make @@ Conv { proj ; inj ; encoding ; schema }
let describe ?title ?description encoding =
match title, description with
| None, None -> encoding
| _, _ -> make @@ Describe { title ; description ; encoding }
let def name encoding = make @@ Def { name ; encoding }
let def id ?title ?description encoding =
make @@ Describe { id ; title ; description ; encoding }
let req ?title ?description n t =
Req { name = n ; encoding = describe ?title ?description t }
Req { name = n ; encoding = t ; title ; description }
let opt ?title ?description n encoding =
let kind =
match classify encoding with
| `Variable -> `Variable
| `Fixed _ | `Dynamic -> `Dynamic in
Opt { name = n ; kind ;
encoding = make @@ Describe { title ; description ; encoding } }
Opt { name = n ; kind ; encoding ; title ; description }
let varopt ?title ?description n encoding =
Opt { name = n ; kind = `Variable ;
encoding = make @@ Describe { title ; description ; encoding } }
Opt { name = n ; kind = `Variable ; encoding ; title ; description }
let dft ?title ?description n t d =
Dft { name = n ;
encoding = describe ?title ?description t ;
default = d }
Dft { name = n ; encoding = t ; default = d ; title ; description }
let raw_splitted ~json ~binary =
make @@ Splitted { encoding = binary ;
@ -371,11 +366,10 @@ let rec is_obj : type a. a t -> bool = fun e ->
List.for_all (fun (Case { encoding = e }) -> is_obj e) cases
| Empty -> true
| Ignore -> true
| Mu (_,_,self) -> is_obj (self e)
| Mu (_,_,_,_,self) -> is_obj (self e)
| Splitted { is_obj } -> is_obj
| Delayed f -> is_obj (f ())
| Describe { encoding } -> is_obj encoding
| Def { encoding } -> is_obj encoding
| _ -> false
let rec is_tup : type a. a t -> bool = fun e ->
@ -386,11 +380,10 @@ let rec is_tup : type a. a t -> bool = fun e ->
| Dynamic_size { encoding = e } -> is_tup e
| Union (_,_,cases) ->
List.for_all (function Case { encoding = e} -> is_tup e) cases
| Mu (_,_,self) -> is_tup (self e)
| Mu (_,_,_,_,self) -> is_tup (self e)
| Splitted { is_tup } -> is_tup
| Delayed f -> is_tup (f ())
| Describe { encoding } -> is_tup encoding
| Def { encoding } -> is_tup encoding
| _ -> false
let raw_merge_objs e1 e2 =
@ -580,10 +573,9 @@ let rec is_nullable: type t. t encoding -> bool = fun e ->
| Tups _ -> false
| Union (_, _, cases) ->
List.exists (fun (Case { encoding = e }) -> is_nullable e) cases
| Mu (_, _, f) -> is_nullable (f e)
| Mu (_, _, _, _, f) -> is_nullable (f e)
| Conv { encoding = e } -> is_nullable e
| Describe { encoding = e } -> is_nullable e
| Def { encoding = e } -> is_nullable e
| Splitted { json_encoding } -> Json_encoding.is_nullable json_encoding
| Dynamic_size { encoding = e } -> is_nullable e
| Check_size { encoding = e } -> is_nullable e
@ -604,16 +596,16 @@ let option ty =
(function None -> Some () | Some _ -> None)
(fun () -> None) ;
]
let mu name self =
let mu name ?title ?description self =
let kind =
try
match classify (self (make @@ Mu (`Dynamic, name, self))) with
match classify (self (make @@ Mu (`Dynamic, name, title, description, self))) with
| `Fixed _ | `Dynamic -> `Dynamic
| `Variable -> raise Exit
with Exit | _ (* TODO variability error *) ->
ignore @@ classify (self (make @@ Mu (`Variable, name, self))) ;
ignore @@ classify (self (make @@ Mu (`Variable, name, title, description, self))) ;
`Variable in
make @@ Mu (kind, name, self)
make @@ Mu (kind, name, title, description, self)
let result ok_enc error_enc =
union

25
src/lib_data_encoding/encoding.mli
View File

@ -49,18 +49,17 @@ type 'a desc =
| Tup : 'a t -> 'a desc
| Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc
| Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc
| Mu : Kind.enum * string * ('a t -> 'a t) -> 'a desc
| Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc
| Conv :
{ proj : ('a -> 'b) ;
inj : ('b -> 'a) ;
encoding : 'b t ;
schema : Json_schema.schema option } -> 'a desc
| Describe :
{ title : string option ;
{ id : string ;
title : string option ;
description : string option ;
encoding : 'a t } -> 'a desc
| Def : { name : string ;
encoding : 'a t } -> 'a desc
| Splitted :
{ encoding : 'a t ;
json_encoding : 'a Json_encoding.encoding ;
@ -74,14 +73,20 @@ type 'a desc =
and _ field =
| Req : { name: string ;
encoding: 'a t ;
title: string option ;
description: string option ;
} -> 'a field
| Opt : { name: string ;
kind: Kind.enum ;
encoding: 'a t ;
title: string option ;
description: string option ;
} -> 'a option field
| Dft : { name: string ;
encoding: 'a t ;
default: 'a ;
title: string option ;
description: string option ;
} -> 'a field
and 'a case =
@ -234,16 +239,20 @@ val case :
val union :
?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding
val describe :
val def :
string ->
?title:string -> ?description:string ->
't encoding ->'t encoding
val def : string -> 'a encoding -> 'a encoding
'a encoding -> 'a encoding
val conv :
('a -> 'b) -> ('b -> 'a) ->
?schema:Json_schema.schema ->
'b encoding -> 'a encoding
val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
val mu :
string ->
?title:string ->
?description: string ->
('a encoding -> 'a encoding) -> 'a encoding
val classify : 'a encoding -> [ `Fixed of int | `Dynamic | `Variable ]
val raw_splitted : json:'a Json_encoding.encoding -> binary:'a encoding -> 'a encoding

13
src/lib_data_encoding/json.ml
View File

@ -46,8 +46,7 @@ let int64_encoding =
let n_encoding =
let open Json_encoding in
def "positive_bignum" @@
describe
def "positive_bignum"
~title: "Positive big number"
~description: "Decimal representation of a positive big number" @@
conv
@ -64,8 +63,7 @@ let n_encoding =
let z_encoding =
let open Json_encoding in
def "bignum" @@
describe
def "bignum"
~title: "Big number"
~description: "Decimal representation of a big number" @@
conv Z.to_string Z.of_string string
@ -210,10 +208,9 @@ let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =
| Tups (_, e1, e2) ->
merge_tups (get_json e1) (get_json e2)
| Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e)
| Describe { title ; description ; encoding = e } ->
describe ?title ?description (get_json e)
| Def { name ; encoding = e } -> def name (get_json e)
| Mu (_, name, self) as ty ->
| Describe { id ; title ; description ; encoding = e } ->
def id ?title ?description (get_json e)
| Mu (_, name, _, _, self) as ty ->
mu name (fun json_encoding -> get_json @@ self (make ~json_encoding ty))
| Union (_tag_size, _, cases) -> union (List.map case_json cases)
| Splitted { json_encoding } -> json_encoding

10
src/lib_error_monad/error_monad.ml
View File

@ -118,7 +118,7 @@ module Make(Prefix : sig val id : string end) = struct
let encoding_case =
let open Data_encoding in
case Json_only
(describe ~title ~description @@
(def "generic_error" ~title ~description @@
conv (fun x -> ((), x)) (fun ((), x) -> x) @@
(obj2
(req "kind" (constant "generic"))
@ -186,7 +186,7 @@ module Make(Prefix : sig val id : string end) = struct
(req "id" (constant name)))
encoding in
case Json_only
(describe ~title ~description
(def name ~title ~description
(conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x)
with_id_and_kind_encoding))
from_error to_error in
@ -293,17 +293,17 @@ module Make(Prefix : sig val id : string end) = struct
let result_encoding t_encoding =
let open Data_encoding in
let errors_encoding =
describe ~title: "An erroneous result" @@
obj1 (req "error" (list error_encoding)) in
let t_encoding =
describe ~title: "A successful result" @@
obj1 (req "result" t_encoding) in
union
~tag_size:`Uint8
[ case (Tag 0) t_encoding
~name:"A successful result"
(function Ok x -> Some x | _ -> None)
(function res -> Ok res) ;
case (Tag 1) errors_encoding
~name:"A erroneous result"
(function Error x -> Some x | _ -> None)
(fun errs -> Error errs) ]
@ -552,7 +552,7 @@ module Make(Prefix : sig val id : string end) = struct
let encoding_case =
let open Data_encoding in
case Json_only
(describe ~title ~description @@
(def "assertion" ~title ~description @@
conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@
(obj3
(req "kind" (constant "assertion"))

5
src/lib_micheline/micheline.ml
View File

@ -20,8 +20,7 @@ type 'p canonical = Canonical of (canonical_location, 'p) node
let canonical_location_encoding =
let open Data_encoding in
def
"micheline.location" @@
describe
"micheline.location"
~title:
"Canonical location in a Micheline expression"
~description:
@ -141,8 +140,6 @@ let canonical_encoding ~variant prim_encoding =
| _ -> None)
(fun (prim, args, annot) -> Prim (0, prim, args, annot)) in
let node_encoding = mu ("micheline." ^ variant ^ ".expression") (fun expr_encoding ->
describe
~title: ("Micheline expression (" ^ variant ^ " variant)") @@
splitted
~json:(union ~tag_size:`Uint8
[ int_encoding Json_only;

14
src/lib_protocol_environment/sigs/v1/data_encoding.mli
View File

@ -171,18 +171,22 @@ val case :
val union :
?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding
val describe :
?title:string -> ?description:string ->
val def :
string ->
?title:string ->
?description:string ->
't encoding ->'t encoding
val def : string -> 'a encoding -> 'a encoding
val conv :
('a -> 'b) -> ('b -> 'a) ->
?schema:json_schema ->
'b encoding -> 'a encoding
val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
val mu :
string ->
?title:string ->
?description:string ->
('a encoding -> 'a encoding) -> 'a encoding
type 'a lazy_t

9
src/lib_rpc/RPC_service.ml
View File

@ -54,17 +54,18 @@ let error_encoding =
match !error_path with
| None -> assert false
| Some p -> p in
describe
def
"error"
~description:
(Printf.sprintf
"The full list of error is available with \
the global RPC `%s %s`"
(string_of_meth meth) (Uri.path_and_query uri))
(conv
(string_of_meth meth) (Uri.path_and_query uri)) @@
conv
~schema:Json_schema.any
(fun exn -> `A (List.map Error_monad.json_of_error exn))
(function `A exns -> List.map Error_monad.error_of_json exns | _ -> [])
json)
json
end
let get_service = get_service ~error:error_encoding

64
src/lib_shell_services/block_services.ml
View File

@ -95,11 +95,9 @@ let pp_block_info ppf
let block_info_encoding =
let operation_encoding =
describe ~title:"Operation hash" @@
merge_objs
(obj1 (req "hash" Operation_hash.encoding))
Operation.encoding in
describe ~title:"Block info" @@
conv
(fun { hash ; chain_id ; level ; proto_level ; predecessor ;
fitness ; timestamp ; protocol ;
@ -138,7 +136,6 @@ type preapply_result = {
}
let preapply_result_encoding =
describe ~title:"Preapply result" @@
(conv
(fun { shell_header ; operations } ->
(shell_header, operations))
@ -191,7 +188,7 @@ module S = struct
RPC_service.post_service
~description:"All the information about a block."
~query: RPC_query.empty
~input: (describe ~title:"Operations" (obj1 (dft "operations" bool true)))
~input: (obj1 (dft "operations" bool true))
~output: block_info_encoding
block_path
@ -200,7 +197,7 @@ module S = struct
~description:"Returns the chain in which the block belongs."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Chain ID" (obj1 (req "chain_id" Chain_id.encoding)))
~output: (obj1 (req "chain_id" Chain_id.encoding))
RPC_path.(block_path / "chain_id")
let level =
@ -208,7 +205,7 @@ module S = struct
~description:"Returns the block's level."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Level" (obj1 (req "level" int32)))
~output: (obj1 (req "level" int32))
RPC_path.(block_path / "level")
let predecessor =
@ -216,7 +213,7 @@ module S = struct
~description:"Returns the previous block's id."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Predecessor" (obj1 (req "predecessor" Block_hash.encoding)))
~output: (obj1 (req "predecessor" Block_hash.encoding))
RPC_path.(block_path / "predecessor")
let predecessors =
@ -224,10 +221,8 @@ module S = struct
~description:
"...."
~query: RPC_query.empty
~input: (describe ~title:"Num predecessors" (obj1 (req "length" Data_encoding.uint16)))
~output:(describe ~title:"Block hash list"
(obj1
(req "blocks" (list Block_hash.encoding))))
~input: (obj1 (req "length" Data_encoding.uint16))
~output: (obj1 (req "blocks" (list Block_hash.encoding)))
RPC_path.(block_path / "predecessors")
let hash =
@ -243,7 +238,7 @@ module S = struct
~description:"Returns the block's fitness."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Fitness" (obj1 (req "fitness" Fitness.encoding)))
~output: (obj1 (req "fitness" Fitness.encoding))
RPC_path.(block_path / "fitness")
let context =
@ -251,7 +246,7 @@ module S = struct
~description:"Returns the hash of the resulting context."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Context hash" (obj1 (req "context" Context_hash.encoding)))
~output: (obj1 (req "context" Context_hash.encoding))
RPC_path.(block_path / "context")
let raw_context_args : string RPC_arg.t =
@ -263,7 +258,6 @@ module S = struct
let raw_context_result_encoding : raw_context_result Data_encoding.t =
let open Data_encoding in
describe ~title:"Raw Context" @@
obj1 (req "content"
(mu "context_tree" (fun raw_context_result_encoding ->
union [
@ -301,7 +295,7 @@ module S = struct
~description:"Returns the block's timestamp."
~query: RPC_query.empty
~input: empty
~output:(describe ~title:"Timestamp" (obj1 (req "timestamp" Time.encoding)))
~output: (obj1 (req "timestamp" Time.encoding))
RPC_path.(block_path / "timestamp")
type operations_param = {
@ -310,7 +304,7 @@ module S = struct
let operations_param_encoding =
let open Data_encoding in
describe ~title:"Operations param" @@
def "next_operation" @@
conv
(fun { contents } -> (contents))
(fun (contents) -> { contents })
@ -322,17 +316,14 @@ module S = struct
~query: RPC_query.empty
~input: operations_param_encoding
~output:
(describe ~title:"Operations" @@
obj1
(obj1
(req "operations"
(list
(describe ~title:"Operation/operation hash pair list"
(list
(describe ~title:"Operation, operation hash pairs"
(obj2
(req "hash" Operation_hash.encoding)
(opt "contents"
(dynamic_size Operation.encoding)))))))))
(dynamic_size Operation.encoding)))))))
RPC_path.(block_path / "operations")
let protocol =
@ -340,8 +331,7 @@ module S = struct
~description:"List the block protocol."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"Block protocol"
(obj1 (req "protocol" Protocol_hash.encoding)))
~output: (obj1 (req "protocol" Protocol_hash.encoding))
RPC_path.(block_path / "protocol")
let test_chain =
@ -360,7 +350,6 @@ module S = struct
}
let preapply_param_encoding =
describe ~title:"Preapply param" @@
(conv
(fun { timestamp ; protocol_data ; operations ; sort_operations } ->
(timestamp, protocol_data, operations, sort_operations))
@ -393,7 +382,7 @@ module S = struct
block, operations, public_keys and contracts."
~query: RPC_query.empty
~input: empty
~output: (describe ~title:"String list" (list string))
~output: (list string)
RPC_path.(block_path / "complete" /: prefix_arg )
type list_param = {
@ -406,7 +395,6 @@ module S = struct
min_heads: int option;
}
let list_param_encoding =
describe ~title:"List blocks param" @@
conv
(fun { include_ops ; length ; heads ; monitor ;
delay ; min_date ; min_heads } ->
@ -417,50 +405,43 @@ module S = struct
delay ; min_date ; min_heads })
(obj7
(dft "include_ops"
(Data_encoding.describe
~description:
"Whether the resulting block informations should include the \
list of operations' hashes. Default false."
bool) false)
bool false)
(opt "length"
(Data_encoding.describe
~description:
"The requested number of predecessors to returns (per \
requested head)."
int31))
int31)
(opt "heads"
(Data_encoding.describe
~description:
"An empty argument requests blocks from the current heads. \
A non empty list allow to request specific fragment \
of the chain."
(list Block_hash.encoding)))
(list Block_hash.encoding))
(opt "monitor"
(Data_encoding.describe
~description:
"When true, the socket is \"kept alive\" after the first \
answer and new heads are streamed when discovered."
bool))
bool)
(opt "delay"
(Data_encoding.describe
~description:
"By default only the blocks that were validated by the node \
are considered. \
When this optional argument is 0, only blocks with a \
timestamp in the past are considered. Other values allows to \
adjust the current time."
int31))
int31)
(opt "min_date"
(Data_encoding.describe
~description: "When `min_date` is provided, heads with a \
timestamp before `min_date` are filtered ouf"
Time.encoding))
Time.encoding)
(opt "min_heads"
(Data_encoding.describe
~description:"When `min_date` is provided, returns at least \
`min_heads` even when their timestamp is before \
`min_date`."
int31)))
int31))
let list =
RPC_service.post_service
@ -481,11 +462,10 @@ module S = struct
~query: RPC_query.empty
~input:empty
~output:(Data_encoding.list
(describe ~title:"Invalid block"
(obj3
(req "block" Block_hash.encoding)
(req "level" int32)
(req "errors" RPC_error.encoding))))
(req "errors" RPC_error.encoding)))
RPC_path.(root / "invalid_blocks")
let unmark_invalid =

1
src/lib_shell_services/block_validator_worker_state.ml
View File

@ -48,7 +48,6 @@ module Event = struct
let encoding =
let open Data_encoding in
describe ~title:"Event state" @@
union
[ case (Tag 0) ~name:"Debug"
(obj1 (req "message" string))

4
src/lib_shell_services/protocol_services.ml
View File

@ -19,9 +19,7 @@ module S = struct
~query: RPC_query.empty
~input: empty
~output:
(obj1 (req "data"
(describe ~title: "Tezos protocol"
(Protocol.encoding))))
(obj1 (req "data" (Protocol.encoding)))
RPC_path.(root / "protocols" /: protocols_arg)
type list_param = {

34
src/lib_shell_services/shell_services.ml
View File

@ -36,24 +36,20 @@ module S = struct
(obj5
(req "data" bytes)
(dft "blocking"
(describe
~description:
"Should the RPC wait for the block to be \
validated before answering. (default: true)"
bool)
bool
true)
(dft "force"
(describe
~description:
"Should we inject the block when its fitness is below \
the current head. (default: false)"
bool)
bool
false)
(opt "chain_id" Chain_id.encoding)
(req "operations"
(describe
~description:"..."
(list (list (dynamic_size Operation.encoding))))))
(list (list (dynamic_size Operation.encoding)))))
let inject_block =
RPC_service.post_service
@ -83,20 +79,17 @@ module S = struct
~input:
(obj3
(req "signedOperationContents"
(describe ~title: "Tezos signed operation (hex encoded)"
bytes))
~title: "Tezos signed operation (hex encoded)"
bytes)
(dft "blocking"
(describe
~description:
"Should the RPC wait for the operation to be \
(pre-)validated before answering. (default: true)"
bool)
bool
true)
(opt "chain_id" Chain_id.encoding))
~output:
(describe
~title: "Hash of the injected operation" @@
(obj1 (req "injectedOperation" Operation_hash.encoding)))
(obj1 (req "injectedOperation" Operation_hash.encoding))
RPC_path.(root / "inject_operation")
let inject_protocol =
@ -106,24 +99,19 @@ module S = struct
~query: RPC_query.empty
~input:
(obj3
(req "protocol"
(describe ~title: "Tezos protocol" Protocol.encoding))
(req "protocol" Protocol.encoding)
(dft "blocking"
(describe
~description:
"Should the RPC wait for the protocol to be \
validated before answering. (default: true)"
bool)
bool
true)
(opt "force"
(describe
~description:
"Should we inject protocol that is invalid. (default: false)"
bool)))
bool))
~output:
(describe
~title: "Hash of the injected protocol" @@
(obj1 (req "injectedProtocol" Protocol_hash.encoding)))
(obj1 (req "injectedProtocol" Protocol_hash.encoding))
RPC_path.(root / "inject_protocol")
let bootstrapped =

2
src/proto_alpha/lib_protocol/src/contract_repr.ml
View File

@ -48,7 +48,7 @@ let pp_short ppf = function
let encoding =
let open Data_encoding in
describe
def "contract_id"
~title:
"A contract handle"
~description:

8
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -123,10 +123,9 @@ module S = struct
~description: "Levels of a cycle"
~query: RPC_query.empty
~input: empty
~output: (describe ~title: "levels of a cycle"
(obj2
~output: (obj2
(req "first" Raw_level.encoding)
(req "last" Raw_level.encoding)))
(req "last" Raw_level.encoding))
RPC_path.(custom_root / "levels" /: Cycle.arg)
end
@ -263,8 +262,7 @@ module Forge = struct
~input: Operation.unsigned_operation_encoding
~output:
(obj1
(req "operation" @@
describe ~title: "hex encoded operation" bytes))
(req "operation" bytes))
RPC_path.(custom_root / "operations" )
let empty_proof_of_work_nonce =

1
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml
View File

@ -394,6 +394,7 @@ let strings_of_prims expr =
let prim_encoding =
let open Data_encoding in
def "michelson.v1.primitives" @@
string_enum [
("parameter", K_parameter) ;
("storage", K_storage) ;

7
src/proto_alpha/lib_protocol/src/operation_repr.ml
View File

@ -113,7 +113,6 @@ module Encoding = struct
open Data_encoding
let reveal_encoding =
describe ~title:"Reveal operation" @@
(obj2
(req "kind" (constant "reveal"))
(req "public_key" Signature.Public_key.encoding))
@ -126,7 +125,6 @@ module Encoding = struct
(fun ((), pkh) -> Reveal pkh)
let transaction_encoding =
describe ~title:"Transaction operation" @@
obj4
(req "kind" (constant "transaction"))
(req "amount" Tez_repr.encoding)
@ -143,7 +141,6 @@ module Encoding = struct
Transaction { amount ; destination ; parameters })
let origination_encoding =
describe ~title:"Origination operation" @@
(obj7
(req "kind" (constant "origination"))
(req "managerPubkey" Signature.Public_key_hash.encoding)
@ -175,7 +172,6 @@ module Encoding = struct
delegate ; script ; preorigination = None })
let delegation_encoding =
describe ~title:"Delegation operation" @@
(obj2
(req "kind" (constant "delegation"))
(opt "delegate" Signature.Public_key_hash.encoding))
@ -419,11 +415,10 @@ module Encoding = struct
mu_proto_operation_encoding operation_encoding
let signed_proto_operation_encoding =
describe ~title:"Signed alpha operation" @@
mu_signed_proto_operation_encoding operation_encoding
let unsigned_operation_encoding =
describe ~title:"Unsigned Alpha operation" @@
def "operation.alpha.unsigned_operation" @@
merge_objs
Operation.shell_header_encoding
proto_operation_encoding

2
src/proto_alpha/lib_protocol/src/qty_repr.ml
View File

@ -223,8 +223,6 @@ module Make (T: QTY) : S = struct
let encoding =
let open Data_encoding in
describe
~title: "Amount in mutez"
(conv to_int64 (Json.wrap_error of_mutez_exn) int64)
let () =

1
src/proto_alpha/lib_protocol/src/script_repr.ml
View File

@ -57,6 +57,7 @@ type t = {
let encoding =
let open Data_encoding in
def "scripted.contracts" @@
conv
(fun { code ; storage } -> (code, storage))
(fun (code, storage) -> { code ; storage })

6
src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml
View File

@ -45,8 +45,7 @@ let () =
let arity_enc =
int8 in
let namespace_enc =
def "primitiveNamespace" @@
describe
def "primitiveNamespace"
~title: "Primitive namespace"
~description:
"One of the three possible namespaces of primitive \
@ -55,8 +54,7 @@ let () =
"constant", Constant_namespace ;
"instruction", Instr_namespace ] in
let kind_enc =
def "expressionKind" @@
describe
def "expressionKind"
~title: "Expression kind"
~description:
"One of the four possible kinds of expression \

3
src/proto_alpha/lib_protocol/src/tez_repr.ml
View File

@ -12,3 +12,6 @@ include Qty_repr.Make (struct let id = "tez" end)
type t = qty
type tez = qty
let encoding =
Data_encoding.def "mutez" @@
encoding

42
vendors/ocplib-json-typed/lib_json_typed/json_encoding.ml vendored
View File

@ -69,10 +69,13 @@ type _ encoding =
| Tups : 'a encoding * 'b encoding -> ('a * 'b) encoding
| Custom : 't repr_agnostic_custom * Json_schema.schema -> 't encoding
| Conv : ('a -> 'b) * ('b -> 'a) * 'b encoding * Json_schema.schema option -> 'a encoding
| Describe : { title: string option ;
| Describe : { id: string ;
title: string option ;
description: string option ;
encoding: 'a encoding } -> 'a encoding
| Mu : { id: string ;
title: string option ;
description: string option ;
self: ('a encoding -> 'a encoding) ;
}-> 'a encoding
| Union : 't case list -> 't encoding
@ -466,17 +469,12 @@ let schema encoding =
minimum = Some (minimum, `Inclusive) ;
maximum = Some (maximum, `Inclusive) })
| Float None -> element (Number numeric_specs)
| Describe { title = None ; description = None ;
encoding = t } -> schema t
| Describe { title = Some _ as title ; description = None ;
encoding = t } ->
{ (schema t) with title }
| Describe { title = None ; description = Some _ as description ;
encoding = t } ->
{ (schema t) with description }
| Describe { title = Some _ as title ; description = Some _ as description ;
encoding = t } ->
{ (schema t) with title ; description }
| Describe { id = name ; title ; description ; encoding } ->
let open Json_schema in
let schema = patch_description ?title ?description (schema encoding) in
let s, def = add_definition name schema !sch in
sch := fst (merge_definitions (!sch, s)) ;
def
| Custom (_, s) ->
sch := fst (merge_definitions (!sch, s)) ;
root s
@ -484,7 +482,7 @@ let schema encoding =
sch := fst (merge_definitions (!sch, s)) ;
root s
| Conv (_, _, t, None) -> schema t
| Mu { id = name ; self = f } ->
| Mu { id = name ; title ; description ; self = f } ->
let fake_schema =
if definition_exists name !sch then
update (definition_ref name) !sch
@ -495,7 +493,10 @@ let schema encoding =
Custom ({ write = (fun _ _ -> assert false) ;
read = (fun _ -> assert false) },
fake_schema) in
let root = schema (f fake_self) in
let root =
patch_description
?title ?description
(schema (f fake_self)) in
let nsch, def = add_definition name root !sch in
sch := nsch ; def
| Array t ->
@ -546,7 +547,7 @@ let opt ?title ?description n t =
let dft ?title ?description n t d =
Dft { name = n ; encoding = t ; title ; description ; default = d }
let mu name self = Mu { id = name ; self }
let mu name ?title ?description self = Mu { id = name ; title ; description ; self }
let null = Null
let int =
Int { int_name = "int" ;
@ -701,8 +702,6 @@ let tup10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 =
let repr_agnostic_custom { write ; read } ~schema =
Custom ({ write ; read }, schema)
let describe ?title ?description t = Describe { title ; encoding = t ; description }
let constant s = Constant s
let string_enum cases =
@ -737,13 +736,8 @@ let string_enum cases =
~schema
string
let def name encoding =
let schema =
let open Json_schema in
let sch = schema encoding in
let sch, def = add_definition name (root sch) sch in
update def sch in
conv (fun v -> v) (fun v -> v) ~schema encoding
let def id ?title ?description encoding =
Describe { id ; title ; description ; encoding }
let assoc : type t. t encoding -> (string * t) list encoding = fun t ->
Ezjsonm_encoding.custom

19
vendors/ocplib-json-typed/lib_json_typed/json_encoding.mli vendored
View File

@ -381,7 +381,11 @@ val conv :
case (obj2 (req "hd" itemencoding) (req "tl" self))
(function hd :: tl -> Some (hd, tl) | [] -> None)
(fun (hd, tl) -> hd :: tl) ]) ]} *)
val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
val mu :
string ->
?title: string ->
?description: string ->
('a encoding -> 'a encoding) -> 'a encoding
(** A raw JSON value in ezjsonm representation. *)
val any_ezjson_value : Json_repr.ezjsonm encoding
@ -398,17 +402,14 @@ val any_schema : Json_schema.schema encoding
May raise {!Bad_schema}. *)
val schema : 't encoding -> Json_schema.schema
(** Annotate a type with a title and description for the JSON schema. *)
val describe :
?title:string ->
?description:string ->
't encoding ->
't encoding
(** Name a definition so its occurences can be shared in the JSON
schema. The first parameter is a path, that must be unique and
respect the format of {!Json_schema.add_definition}. *)
val def : string -> 't encoding -> 't encoding
val def :
string ->
?title:string ->
?description:string ->
't encoding -> 't encoding
(** {2 Errors} *) (************************************************************)