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

Updater: simplify signature and error registration.

Browse Source 
In particular, register the `Ecoproto_error` at the same time the
functor `Environment.Make` is applied.
This commit is contained in:
Grégoire Henry 2017-10-27 18:53:07 +02:00 committed by Benjamin Canou
parent 90f9f51421
commit dd9e5f5c95
16 changed files with 219 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/client/embedded/alpha/client_proto_alpha.ml
View File

@ -13,4 +13,4 @@ module Environment = Tezos_protocol_environment.Make(Raw.Register.Name)()
module P = Raw.Functor.Make(Environment)
include P
include Updater.WrapProtocol(Raw.Register.Name)(Environment)(P)
include Updater.LiftProtocol(Raw.Register.Name)(Environment)(P)

2
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -15,7 +15,7 @@ module ContractEntity = struct
let of_source _ s =
match Contract.of_b58check s with
| Error _ as err ->
Lwt.return (wrap_error err)
Lwt.return (Environment.wrap_error err)
|> trace (failure "bad contract notation")
| Ok s -> return s
let to_source _ s = return (Contract.to_b58check s)

10
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -569,7 +569,7 @@ let report_errors cctxt errs =
print_error_trace locations errs in
Lwt_list.iter_s
(function
| Ecoproto_error errs ->
| Environment.Ecoproto_error errs ->
print_error_trace no_locations errs
| err -> cctxt.warning "%a" pp_print_error [ err ])
errs
@ -831,12 +831,12 @@ let commands () =
let cctxt = Client_commands.make_context
(fun _ t -> Buffer.add_string msg t ; Buffer.add_char msg '\n' ; Lwt.return ()) in
match errs with
| Ecoproto_error (Script_ir_translator.Ill_formed_type
| Environment.Ecoproto_error (Script_ir_translator.Ill_formed_type
(Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ ->
report_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () ->
Lwt.return ([], [ List.assoc 0 (List.assoc field program.loc_table), Buffer.contents msg ])
| Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ ->
(report_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
| Environment.Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ ->
(report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () ->
let (types, _) = emacs_type_map type_map in
let loc = match collect_error_locations errs with
| hd :: _ -> hd

4
src/client/embedded/alpha/client_proto_rpcs.ml
View File

@ -24,7 +24,7 @@ let call_service1 cctxt s block a1 =
(s Node_rpc_services.Blocks.proto_path) block a1
let call_error_service1 cctxt s block a1 =
call_service1 cctxt s block a1 >>= function
| Ok (Error _ as err) -> Lwt.return (wrap_error err)
| Ok (Error _ as err) -> Lwt.return (Environment.wrap_error err)
| Ok (Ok v) -> return v
| Error _ as err -> Lwt.return err
let call_service2 cctxt s block a1 a2 =
@ -32,7 +32,7 @@ let call_service2 cctxt s block a1 a2 =
(s Node_rpc_services.Blocks.proto_path) block a1 a2
let call_error_service2 cctxt s block a1 a2 =
call_service2 cctxt s block a1 a2 >>= function
| Ok (Error _ as err) -> Lwt.return (wrap_error err)
| Ok (Error _ as err) -> Lwt.return (Environment.wrap_error err)
| Ok (Ok v) -> return v
| Error _ as err -> Lwt.return err

2
src/client/embedded/demo/client_proto_demo.ml
View File

@ -13,4 +13,4 @@ module Environment = Tezos_protocol_environment.Make(Raw.Register.Name)()
module P = Raw.Functor.Make(Environment)
include P
include Updater.WrapProtocol(Raw.Register.Name)(Environment)(P)
include Updater.LiftProtocol(Raw.Register.Name)(Environment)(P)

8
src/client/embedded/demo/client_proto_main.ml
View File

@ -20,13 +20,13 @@ let demo cctxt =
begin
cctxt.message "Calling the 'failing' RPC." >>= fun () ->
Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function
| Error [Ecoproto_error [Error.Demo_error 3]] ->
| Error [Environment.Ecoproto_error [Error.Demo_error 3]] ->
return ()
| _ -> failwith "..."
end >>=? fun () ->
cctxt.message "Direct call to `demo_error`." >>= fun () ->
begin Error.demo_error 101010 >|= wrap_error >>= function
| Error [Ecoproto_error [Error.Demo_error 101010]] ->
begin Error.demo_error 101010 >|= Environment.wrap_error >>= function
| Error [Environment.Ecoproto_error [Error.Demo_error 101010]] ->
return ()
| _ -> failwith "...."
end >>=? fun () ->
@ -79,7 +79,7 @@ let commands () =
(fixed [ "fail" ])
(fun () _cctxt ->
Error.demo_error 101010
>|= wrap_error) ;
>|= Environment.wrap_error) ;
command ~group ~desc: "Mine an empty block"
no_options
(fixed [ "mine" ])

2
src/client/embedded/demo/client_proto_rpcs.ml
View File

@ -12,7 +12,7 @@ let call_service1 cctxt s block a1 =
(s Node_rpc_services.Blocks.proto_path) block a1
let call_error_service1 cctxt s block a1 =
call_service1 cctxt s block a1 >>= function
| Ok (Error _ as err) -> Lwt.return (wrap_error err)
| Ok (Error _ as err) -> Lwt.return (Environment.wrap_error err)
| Ok (Ok v) -> return v
| Error _ as err -> Lwt.return err

2
src/client/embedded/genesis/client_proto_genesis.ml
View File

@ -13,4 +13,4 @@ module Environment = Tezos_protocol_environment.Make(Raw.Register.Name)()
module P = Raw.Functor.Make(Environment)
include P
include Updater.WrapProtocol(Raw.Register.Name)(Environment)(P)
include Updater.LiftProtocol(Raw.Register.Name)(Environment)(P)

2
src/client/embedded/genesis/client_proto_main.ml
View File

@ -19,7 +19,7 @@ let call_service1 rpc_config s block a1 =
let call_error_service1 rpc_config s block a1 =
call_service1 rpc_config s block a1 >>= function
| Ok (Error _ as err) -> Lwt.return (wrap_error err)
| Ok (Error _ as err) -> Lwt.return (Environment.wrap_error err)
| Ok (Ok v) -> return v
| Error _ as err -> Lwt.return err

35
src/node/shell/state.ml
View File

@ -581,8 +581,7 @@ module Registred_protocol = struct
module type T = sig
val hash: Protocol_hash.t
include Updater.RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
include Updater.NODE_PROTOCOL
val complete_b58prefix : Context.t -> string -> string list Lwt.t
end
@ -596,7 +595,7 @@ module Registred_protocol = struct
let hash = hash
module P = F(Env)
include P
include Updater.WrapProtocol(Name)(Env)(P)
include Updater.LiftProtocol(Name)(Env)(P)
let complete_b58prefix = Env.Context.complete
end : T)
@ -619,6 +618,36 @@ module Registred_protocol = struct
try Some (get_exn hash)
with Not_found -> None
end
module Register_embedded_protocol
(Env : Updater.Node_protocol_environment_sigs.V1)
(Proto : Env.Updater.PROTOCOL)
(Source : sig
val hash: Protocol_hash.t option
val sources: Tezos_data.Protocol.t
end) = struct
let () =
let hash =
match Source.hash with
| None -> Tezos_data.Protocol.hash Source.sources
| Some hash -> hash in
let module Name = struct
let name = Protocol_hash.to_b58check hash
end in
(* TODO add a memory table for "embedded" sources... *)
Registred_protocol.VersionTable.add
Registred_protocol.versions hash
(module struct
let hash = hash
include Proto
include Updater.LiftProtocol(Name)(Env)(Proto)
let complete_b58prefix = Env.Context.complete
end : Registred_protocol.T)
end
let read

11
src/node/shell/state.mli
View File

@ -195,8 +195,7 @@ module Registred_protocol : sig
module type T = sig
val hash: Protocol_hash.t
include Updater.RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
include Updater.NODE_PROTOCOL
val complete_b58prefix : Context.t -> string -> string list Lwt.t
end
@ -206,3 +205,11 @@ module Registred_protocol : sig
val get_exn: Protocol_hash.t -> (module T)
end
module Register_embedded_protocol
(Env : Updater.Node_protocol_environment_sigs.V1)
(Proto : Env.Updater.PROTOCOL)
(Source : sig
val hash: Protocol_hash.t option
val sources: Tezos_data.Protocol.t
end) : sig end

23
src/node/updater/tezos_protocol_environment.ml
View File

@ -280,4 +280,27 @@ module Make(Param : sig val name: string end)() = struct
let register_resolver = Base58.register_resolver
let complete ctxt s = Base58.complete ctxt s
end
type error += Ecoproto_error of Error_monad.error list
let () =
let id = Format.asprintf "Ecoproto.%s" Param.name in
register_wrapped_error_kind
(fun ecoerrors -> Error_monad.classify_errors ecoerrors)
~id ~title:"Error returned by the protocol"
~description:"Wrapped error for the economic protocol."
~pp:(fun ppf ->
Format.fprintf ppf
"@[<v 2>Economic error:@ %a@]"
(Format.pp_print_list Error_monad.pp))
Data_encoding.(obj1 (req "ecoproto"
(list Error_monad.error_encoding)))
(function Ecoproto_error ecoerrors -> Some ecoerrors
| _ -> None )
(function ecoerrors -> Ecoproto_error ecoerrors)
let wrap_error = function
| Ok _ as ok -> ok
| Error errors -> Error [Ecoproto_error errors]
end

165
src/node/updater/updater.ml
View File

@ -26,47 +26,6 @@ type rpc_context = {
context: Context.t ;
}
module type RAW_PROTOCOL = sig
type error = ..
type 'a tzresult
type operation
val max_operation_data_length: int
val max_block_length: int
val max_number_of_operations: int
val parse_operation:
Operation_hash.t -> Operation.t -> operation tzresult
val compare_operations: operation -> operation -> int
type validation_state
val current_context: validation_state -> Context.t tzresult Lwt.t
val precheck_block:
ancestor_context: Context.t ->
ancestor_timestamp: Time.t ->
Block_header.t ->
unit tzresult Lwt.t
val begin_application:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.t ->
Block_header.t ->
validation_state tzresult Lwt.t
val begin_construction:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.t ->
predecessor: Block_hash.t ->
timestamp: Time.t ->
?proto_header: MBytes.t ->
unit -> validation_state tzresult Lwt.t
val apply_operation:
validation_state -> operation -> validation_state tzresult Lwt.t
val finalize_block:
validation_state -> validation_result tzresult Lwt.t
val rpc_services: rpc_context RPC.directory
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
let activate = Context.set_protocol
let fork_test_network = Context.fork_test_network
@ -152,48 +111,94 @@ let compile hash p =
Lwt.return loaded
end
module type REGISTRED_PROTOCOL = sig
val hash: Protocol_hash.t
include RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
val complete_b58prefix : Context.t -> string -> string list Lwt.t
module Node_protocol_environment_sigs = struct
module type V1 = sig
include Tezos_protocol_environment_sigs_v1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Hash.Net_id.t = Hash.Net_id.t
and type Hash.Block_hash.t = Hash.Block_hash.t
and type Hash.Operation_hash.t = Hash.Operation_hash.t
and type Hash.Operation_list_list_hash.t = Hash.Operation_list_list_hash.t
and type Context.t = Context.t
and type Time.t = Time.t
and type MBytes.t = MBytes.t
and type Tezos_data.Operation.shell_header = Tezos_data.Operation.shell_header
and type Tezos_data.Operation.t = Tezos_data.Operation.t
and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header
and type Tezos_data.Block_header.t = Tezos_data.Block_header.t
and type 'a RPC.directory = 'a RPC.directory
and type Updater.validation_result = validation_result
and type Updater.rpc_context = rpc_context
type error += Ecoproto_error of Error_monad.error list
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
end
end
module WrapProtocol
module type RAW_PROTOCOL = sig
type error = ..
type 'a tzresult = ('a, error list) result
type operation
val max_operation_data_length: int
val max_block_length: int
val max_number_of_operations: int
val parse_operation:
Operation_hash.t -> Operation.t -> operation tzresult
val compare_operations: operation -> operation -> int
type validation_state
val current_context: validation_state -> Context.t tzresult Lwt.t
val precheck_block:
ancestor_context: Context.t ->
ancestor_timestamp: Time.t ->
Block_header.t ->
unit tzresult Lwt.t
val begin_application:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.t ->
Block_header.t ->
validation_state tzresult Lwt.t
val begin_construction:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.t ->
predecessor: Block_hash.t ->
timestamp: Time.t ->
?proto_header: MBytes.t ->
unit -> validation_state tzresult Lwt.t
val apply_operation:
validation_state -> operation -> validation_state tzresult Lwt.t
val finalize_block:
validation_state -> validation_result tzresult Lwt.t
val rpc_services: rpc_context RPC.directory
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
module type NODE_PROTOCOL =
RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
module LiftProtocol
(Name : sig val name: string end)
(Env : Tezos_protocol_environment_sigs_v1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) Pervasives.result)
(Env : Node_protocol_environment_sigs.V1)
(P : Env.Updater.PROTOCOL) = struct
type proto_error = Env.Error_monad.error
type error += Ecoproto_error of proto_error list
let wrap_error = function
| Ok _ as ok -> ok
| Error errors -> Error [Ecoproto_error errors]
let () =
let id = Format.asprintf "Ecoproto.%s" Name.name in
Error_monad.register_wrapped_error_kind
(fun ecoerrors -> Env.Error_monad.classify_errors ecoerrors)
~id ~title:"Error returned by the protocol"
~description:"Wrapped error for the economic protocol."
~pp:(fun ppf ->
Format.fprintf ppf
"@[<v 2>Economic error:@ %a@]"
(Format.pp_print_list Env.Error_monad.pp))
Data_encoding.(obj1 (req "ecoproto"
(list Env.Error_monad.error_encoding)))
(function Ecoproto_error ecoerrors -> Some ecoerrors
| _ -> None )
(function ecoerrors -> Ecoproto_error ecoerrors)
include P
let precheck_block
~ancestor_context ~ancestor_timestamp
raw_block =
precheck_block
~ancestor_context ~ancestor_timestamp
raw_block >|= wrap_error
raw_block >|= Env.wrap_error
let begin_application
~predecessor_context ~predecessor_timestamp
~predecessor_fitness
@ -201,7 +206,7 @@ module WrapProtocol
begin_application
~predecessor_context ~predecessor_timestamp
~predecessor_fitness
raw_block >|= wrap_error
raw_block >|= Env.wrap_error
let begin_construction
~predecessor_context ~predecessor_timestamp
~predecessor_level ~predecessor_fitness
@ -209,13 +214,13 @@ module WrapProtocol
begin_construction
~predecessor_context ~predecessor_timestamp
~predecessor_level ~predecessor_fitness
~predecessor ~timestamp ?proto_header () >|= wrap_error
~predecessor ~timestamp ?proto_header () >|= Env.wrap_error
let current_context c =
current_context c >|= wrap_error
current_context c >|= Env.wrap_error
let apply_operation c o =
apply_operation c o >|= wrap_error
let finalize_block c = finalize_block c >|= wrap_error
let parse_operation h b = parse_operation h b |> wrap_error
apply_operation c o >|= Env.wrap_error
let finalize_block c = finalize_block c >|= Env.wrap_error
let parse_operation h b = parse_operation h b |> Env.wrap_error
let configure_sandbox c j =
configure_sandbox c j >|= wrap_error
configure_sandbox c j >|= Env.wrap_error
end

84
src/node/updater/updater.mli
View File

@ -9,6 +9,14 @@
(* See `src/environment/v1//updater.mli` for documentation. *)
val compile: Protocol_hash.t -> Protocol.t -> bool Lwt.t
val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val fork_test_network:
Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
val extract: Lwt_io.file_name -> ?hash:Protocol_hash.t -> Protocol.t -> unit Lwt.t
val init: string -> unit
type validation_result = {
context: Context.t ;
fitness: Fitness.t ;
@ -26,7 +34,7 @@ type rpc_context = {
module type RAW_PROTOCOL = sig
type error = ..
type 'a tzresult
type 'a tzresult = ('a, error list) result
type operation
val max_operation_data_length: int
val max_block_length: int
@ -65,39 +73,47 @@ module type RAW_PROTOCOL = sig
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
val compile: Protocol_hash.t -> Protocol.t -> bool Lwt.t
val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val fork_test_network:
Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
(**/**)
val extract: Lwt_io.file_name -> ?hash:Protocol_hash.t -> Protocol.t -> unit Lwt.t
val init: string -> unit
(* The end of this file is not exported to the protocol... *)
module Node_protocol_environment_sigs : sig
module type V1 = sig
include Tezos_protocol_environment_sigs_v1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Hash.Net_id.t = Hash.Net_id.t
and type Hash.Block_hash.t = Hash.Block_hash.t
and type Hash.Operation_hash.t = Hash.Operation_hash.t
and type Hash.Operation_list_list_hash.t = Hash.Operation_list_list_hash.t
and type Context.t = Context.t
and type Time.t = Time.t
and type MBytes.t = MBytes.t
and type Tezos_data.Operation.shell_header = Tezos_data.Operation.shell_header
and type Tezos_data.Operation.t = Tezos_data.Operation.t
and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header
and type Tezos_data.Block_header.t = Tezos_data.Block_header.t
and type 'a RPC.directory = 'a RPC.directory
and type Updater.validation_result = validation_result
and type Updater.rpc_context = rpc_context
type error += Ecoproto_error of Error_monad.error list
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
end
module WrapProtocol(Name : sig val name: string end)
(Env : Tezos_protocol_environment_sigs_v1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Hash.Net_id.t = Hash.Net_id.t
and type Hash.Block_hash.t = Hash.Block_hash.t
and type Hash.Operation_hash.t = Hash.Operation_hash.t
and type Hash.Operation_list_list_hash.t = Hash.Operation_list_list_hash.t
and type Context.t = Context.t
and type Time.t = Time.t
and type MBytes.t = MBytes.t
and type Tezos_data.Operation.shell_header = Tezos_data.Operation.shell_header
and type Tezos_data.Operation.t = Tezos_data.Operation.t
and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header
and type Tezos_data.Block_header.t = Tezos_data.Block_header.t
and type 'a RPC.directory = 'a RPC.directory
and type Updater.validation_result = validation_result
and type Updater.rpc_context = rpc_context)
(P : Env.Updater.PROTOCOL) : sig
include RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
and type operation := P.operation
and type validation_state := P.validation_state
type error += Ecoproto_error of Env.Error_monad.error list
val wrap_error: 'a Env.Error_monad.tzresult -> 'a tzresult
end
module type NODE_PROTOCOL =
RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
module LiftProtocol(Name : sig val name: string end)
(Env : Node_protocol_environment_sigs.V1)
(P : Env.Updater.PROTOCOL) :
NODE_PROTOCOL with type operation := P.operation
and type validation_state := P.validation_state

4
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -314,7 +314,7 @@ module Assert = struct
equal_pkh ~msg actual_delegate expected_delegate
let ecoproto_error f = function
| Ecoproto_error errors ->
| Environment.Ecoproto_error errors ->
List.exists f errors
| _ -> false
@ -429,7 +429,7 @@ module Mining = struct
let endorsement_reward block =
Client_proto_rpcs.Header.priority rpc_config block >>=? fun prio ->
Mining.endorsement_reward ~block_priority:prio >|=
wrap_error >>|?
Environment.wrap_error >>|?
Tez.to_cents
end

2
test/utils/test_lwt_pipe.ml
View File

@ -20,7 +20,7 @@ let rec gen acc f = function
| n -> gen (f () :: acc) f (pred n)
let run qsize nbp nbc p c =
let q = Lwt_pipe.create qsize in
let q = Lwt_pipe.create ~size:(qsize, fun () -> qsize) () in
let producers = gen [] (fun () -> producer q p) nbp in
let consumers = gen [] (fun () -> consumer q c) nbc in
Lwt.join producers <&> Lwt.join consumers