From dc2cd4db1c2d0b1b550c9ba7b43d157f3dc0975f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Fri, 27 Oct 2017 18:41:59 +0200 Subject: [PATCH] Utils: add `Data_encoding.delayed` This allows a better representation for `Error_monad.error_encoding`, capturing the side-effect of new error registration. --- src/environment/v1/error_monad.mli | 2 +- src/minutils/data_encoding.ml | 11 +++++++++++ src/minutils/data_encoding.mli | 2 ++ src/node/shell/node_rpc.ml | 2 +- src/node/updater/updater.ml | 2 +- src/proto/alpha/services_registration.ml | 2 +- src/utils/error_monad.ml | 8 +++++--- src/utils/error_monad_sig.ml | 2 +- 8 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/environment/v1/error_monad.mli b/src/environment/v1/error_monad.mli index 6e76d743c..b48e895ad 100644 --- a/src/environment/v1/error_monad.mli +++ b/src/environment/v1/error_monad.mli @@ -16,7 +16,7 @@ type error = .. val pp : Format.formatter -> error -> unit (** A JSON error serializer *) -val error_encoding : unit -> error Data_encoding.t +val error_encoding : error Data_encoding.t val json_of_error : error -> Data_encoding.json val error_of_json : Data_encoding.json -> error diff --git a/src/minutils/data_encoding.ml b/src/minutils/data_encoding.ml index 47b60411a..5e43e6cf0 100644 --- a/src/minutils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -152,6 +152,7 @@ type 'a desc = { encoding : 'a t ; json_encoding : 'a Json_encoding.encoding } -> 'a desc | Dynamic_size : 'a t -> 'a desc + | Delayed : (unit -> 'a t) -> 'a desc and _ field = | Req : string * 'a t -> 'a field @@ -209,6 +210,7 @@ let rec classify : type a l. a t -> Kind.t = fun e -> | Def { encoding } -> classify encoding | Splitted { encoding } -> classify encoding | Dynamic_size _ -> `Dynamic + | Delayed f -> classify (f ()) let make ?json_encoding encoding = { encoding ; json_encoding } @@ -357,6 +359,7 @@ module Json = struct | Union (_tag_size, _, cases) -> union (List.map case_json cases) | Splitted { json_encoding } -> json_encoding | Dynamic_size e -> get_json e + | Delayed f -> get_json (f ()) and field_json : type a l. a field -> a Json_encoding.field = @@ -434,6 +437,9 @@ module Encoding = struct let dynamic_size e = make @@ Dynamic_size e + let delayed f = + make @@ Delayed f + let null = make @@ Null let empty = make @@ Empty let unit = make @@ Ignore @@ -838,6 +844,7 @@ let rec length : type x. x t -> x -> int = fun e -> | Dynamic_size e -> let length = length e in fun v -> Size.int32 + length v + | Delayed f -> length (f ()) (** Writer *) @@ -1000,6 +1007,7 @@ let rec length : type x. x t -> x -> int = fun e -> and write = write_rec e in fun v buf ofs -> int32 (Int32.of_int @@ length v) buf ofs |> write v buf + | Delayed f -> write_rec (f ()) let write t v buf ofs = try Some (write_rec t v buf ofs) @@ -1217,6 +1225,7 @@ let rec length : type x. x t -> x -> int = fun e -> let sz = Int32.to_int sz in if sz < 0 then raise (Invalid_size sz); read buf ofs sz + | Delayed f -> read_rec (f ()) let read t buf ofs len = try Some (read_rec t buf ofs len) @@ -1513,6 +1522,8 @@ let rec length : type x. x t -> x -> int = fun e -> if sz < 0 then raise (Invalid_size sz) ; data_checker path e buf sz + | Delayed f -> data_checker path (f ()) buf len + with Need_more_data -> P_await { path ; encoding = e ; data_len = len }, buf diff --git a/src/minutils/data_encoding.mli b/src/minutils/data_encoding.mli index 56f492f19..dc10dac0a 100644 --- a/src/minutils/data_encoding.mli +++ b/src/minutils/data_encoding.mli @@ -64,6 +64,8 @@ end val dynamic_size : 'a encoding -> 'a encoding +val delayed : (unit -> 'a encoding) -> 'a encoding + val json : json encoding val json_schema : json_schema encoding diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 5f8910636..5ee12d9cb 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -427,7 +427,7 @@ let build_rpc_directory node = let dir = let implementation () = RPC.Answer.return - Data_encoding.Json.(schema (Error_monad.error_encoding ())) in + Data_encoding.Json.(schema Error_monad.error_encoding) in RPC.register0 dir Services.Error.service implementation in let dir = RPC.register1 dir Services.complete diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 59b075a4b..73f701d6b 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -183,7 +183,7 @@ module WrapProtocol "@[Economic error:@ %a@]" (Format.pp_print_list Env.Error_monad.pp)) Data_encoding.(obj1 (req "ecoproto" - (list (Env.Error_monad.error_encoding ())))) + (list Env.Error_monad.error_encoding))) (function Ecoproto_error ecoerrors -> Some ecoerrors | _ -> None ) (function ecoerrors -> Ecoproto_error ecoerrors) diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index 4ff7022bb..2350d0fd3 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -139,7 +139,7 @@ let () = let () = register1_noctxt Services.Constants.errors (fun () -> - Lwt.return (Data_encoding.Json.(schema (error_encoding ())))) + Lwt.return (Data_encoding.Json.(schema error_encoding))) (*-- Context -----------------------------------------------------------------*) diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index e0183c861..15494a984 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -117,10 +117,12 @@ module Make() = struct encoding | Some encoding -> encoding + let error_encoding = Data_encoding.delayed error_encoding + let json_of_error error = - Data_encoding.Json.(construct (error_encoding ())) error + Data_encoding.Json.construct error_encoding error let error_of_json json = - Data_encoding.Json.(destruct (error_encoding ())) json + Data_encoding.Json.destruct error_encoding json let classify_error error = let rec find e = function @@ -166,7 +168,7 @@ module Make() = struct let open Data_encoding in let errors_encoding = describe ~title: "An erroneous result" @@ - obj1 (req "error" (list (error_encoding ()))) in + obj1 (req "error" (list error_encoding)) in let t_encoding = describe ~title: "A successful result" @@ obj1 (req "result" t_encoding) in diff --git a/src/utils/error_monad_sig.ml b/src/utils/error_monad_sig.ml index 0f7a5d190..267c4dc2a 100644 --- a/src/utils/error_monad_sig.ml +++ b/src/utils/error_monad_sig.ml @@ -22,7 +22,7 @@ module type S = sig val pp_print_error: Format.formatter -> error list -> unit (** An error serializer *) - val error_encoding : unit -> error Data_encoding.t + val error_encoding : error Data_encoding.t val json_of_error : error -> Data_encoding.json val error_of_json : Data_encoding.json -> error