From efdf8c74ebe2bec1da13663c146866a846b92f98 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Tue, 25 Jul 2017 14:03:49 +0200 Subject: [PATCH] Michelson: better propagation and printing of errors to the client --- .../embedded/alpha/client_proto_context.ml | 26 ++++--- .../embedded/alpha/client_proto_programs.ml | 67 +++++++++++-------- .../embedded/alpha/client_proto_programs.mli | 2 + src/proto/alpha/script_interpreter.ml | 28 ++++++-- src/proto/alpha/script_interpreter.mli | 2 + src/proto/alpha/script_ir_translator.ml | 41 +++++++----- src/utils/error_monad.ml | 2 +- 7 files changed, 112 insertions(+), 56 deletions(-) diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index c9153e116..6ea794502 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -380,12 +380,16 @@ let commands () = originate_contract cctxt.rpc_config cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init - () >>=? fun (oph, contract) -> - message_injection cctxt - ~force:!force ~contracts:[contract] oph >>= fun () -> - RawContractAlias.add cctxt neu contract >>=? fun () -> - message_added_contract cctxt neu >>= fun () -> - return () + () >>=function + | Error errs -> + Client_proto_programs.report_errors cctxt errs >>= fun () -> + cctxt.error "origination simulation failed" + | Ok (oph, contract) -> + message_injection cctxt + ~force:!force ~contracts:[contract] oph >>= fun () -> + RawContractAlias.add cctxt neu contract >>=? fun () -> + message_added_contract cctxt neu >>= fun () -> + return () end ; command ~group ~desc: "open a new (free) account" @@ -425,9 +429,13 @@ let commands () = get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> transfer cctxt.rpc_config cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~destination - ?arg:!arg ~amount ~fee:!fee () >>=? fun (oph, contracts) -> - message_injection cctxt ~force:!force ~contracts oph >>= fun () -> - return () + ?arg:!arg ~amount ~fee:!fee () >>= function + | Error errs -> + Client_proto_programs.report_errors cctxt errs >>= fun () -> + cctxt.error "transfer simulation failed" + | Ok (oph, contracts) -> + message_injection cctxt ~force:!force ~contracts oph >>= fun () -> + return () end; command ~desc: "Activate a protocol" begin diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 2e9d65587..3ac378ab1 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -185,6 +185,7 @@ let print_program locations ppf ((c : Script.code), type_map) = let collect_error_locations errs = let open Script_typed_ir in let open Script_ir_translator in + let open Script_interpreter in let rec collect acc = function | (Ill_typed_data (_, _, _) | Ill_formed_type (_, _) @@ -205,15 +206,19 @@ let collect_error_locations errs = | Transfer_in_lambda loc | Invalid_constant (loc, _, _) | Invalid_contract (loc, _) - | Comparable_type_expected (loc, _)) :: rest -> + | Comparable_type_expected (loc, _) + | Overflow loc + | Reject loc + | Division_by_zero loc) :: rest -> collect (loc :: acc) rest | _ :: rest -> collect acc rest in collect [] errs -let report_typechecking_errors ?show_types cctxt errs = +let report_errors cctxt errs = let open Client_commands in let open Script_typed_ir in let open Script_ir_translator in + let open Script_interpreter in let rec print_ty (type t) ppf (ty : t ty) = let expr = unparse_ty ty in print_expr no_locations ppf expr in @@ -246,7 +251,7 @@ let report_typechecking_errors ?show_types cctxt errs = Format.fprintf ppf "%a,@ %a" Format.pp_print_text first print_enumeration rest | [] -> assert false in - let print_typechecking_error locations err = + let print_error locations err = let print_loc ppf loc = match locations loc with | None -> @@ -273,12 +278,18 @@ let report_typechecking_errors ?show_types cctxt errs = name (print_expr locations) expr | Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map) -> - (match show_types with - | Some prog -> cctxt.message "%a\n" (print_program no_locations) (prog, type_map) - | None -> Lwt.return ()) >>= fun () -> cctxt.warning "@[Ill typed contract:@ %a@]" (print_program locations) + ({ Script.storage_type = unparse_ty storage_ty ; + arg_type = unparse_ty arg_ty ; + ret_type = unparse_ty ret_ty ; + code = expr }, type_map) + | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) -> + cctxt.warning + "@[Runtime error in contract %a:@ %a@]" + Contract.pp contract + (print_program locations) ({ Script.storage_type = unparse_ty storage_ty ; arg_type = unparse_ty arg_ty ; ret_type = unparse_ty ret_ty ; @@ -416,14 +427,18 @@ let report_typechecking_errors ?show_types cctxt errs = "@[@[Type@ %a@]@ \ @[is not compatible with type@ %a.@]@]" print_ty tya print_ty tyb + | Reject _ -> cctxt.warning "Script reached FAIL instruction" + | Overflow _ -> cctxt.warning "Unexpected arithmetic overflow" + | Division_by_zero _ -> cctxt.warning "Division by zero" | err -> cctxt.warning "%a" Local_environment.Environment.Error_monad.pp_print_error [ err ] in - let rec print_typechecking_error_trace locations errs = + let rec print_error_trace locations errs = let locations = match errs with | (Ill_typed_data (_, _, _) | Ill_formed_type (_, _) - | Ill_typed_contract (_, _, _, _, _)) :: rest -> + | Ill_typed_contract (_, _, _, _, _) + | Runtime_contract_error (_, _, _, _, _)) :: rest -> let collected = collect_error_locations rest in let assoc, _ = @@ -439,12 +454,12 @@ let report_typechecking_errors ?show_types cctxt errs = match errs with | [] -> Lwt.return () | err :: errs -> - print_typechecking_error locations err >>= fun () -> - print_typechecking_error_trace locations errs in + print_error locations err >>= fun () -> + print_error_trace locations errs in Lwt_list.iter_s (function | Ecoproto_error errs -> - print_typechecking_error_trace no_locations errs + print_error_trace no_locations errs | err -> cctxt.warning "%a" pp_print_error [ err ]) errs @@ -631,6 +646,10 @@ let commands () = @@ stop) (fun program storage input cctxt -> let open Data_encoding in + let print_errors errs = + report_errors cctxt errs >>= fun () -> + cctxt.error "error running program" >>= fun () -> + return () in if !trace_stack then Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function @@ -650,10 +669,7 @@ let commands () = stack)) trace >>= fun () -> return () - | Error errs -> - report_typechecking_errors cctxt errs >>= fun () -> - cctxt.error "error running program" >>= fun () -> - return () + | Error errs -> print_errors errs else Client_proto_rpcs.Helpers.run_code cctxt.rpc_config cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function @@ -663,9 +679,7 @@ let commands () = (print_expr no_locations) output >>= fun () -> return () | Error errs -> - report_typechecking_errors cctxt errs >>= fun () -> - cctxt.error "error running program" >>= fun () -> - return ()) ; + print_errors errs); command ~group ~desc: "ask the node to typecheck a program" ~args: [ show_types_arg ; emacs_mode_arg ] @@ -697,10 +711,10 @@ let commands () = match errs with | Ecoproto_error (Script_ir_translator.Ill_formed_type (Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ -> - report_typechecking_errors cctxt [ Ecoproto_error errs ] >>= fun () -> + report_errors cctxt [ 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_typechecking_errors cctxt [ Ecoproto_error errs ] >>= fun () -> + (report_errors cctxt [ Ecoproto_error errs ] >>= fun () -> let (types, _) = emacs_type_map type_map in let loc = match collect_error_locations errs with | hd :: _ -> hd @@ -738,9 +752,8 @@ let commands () = return () else return () | Error errs -> - report_typechecking_errors - ?show_types:(if !show_types then Some program.ast else None) cctxt errs >>= fun () -> - failwith "ill-typed program") ; + report_errors cctxt errs >>= fun () -> + cctxt.error "ill-typed program") ; command ~group ~desc: "ask the node to typecheck a data expression" (prefixes [ "typecheck" ; "data" ] @@ -758,8 +771,8 @@ let commands () = cctxt.message "Well typed" >>= fun () -> return () | Error errs -> - report_typechecking_errors cctxt errs >>= fun () -> - failwith "ill-typed data") ; + report_errors cctxt errs >>= fun () -> + cctxt.error "ill-typed data") ; command ~group ~desc: "ask the node to compute the hash of a data expression \ @@ -777,7 +790,7 @@ let commands () = return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - failwith "ill-formed data") ; + cctxt.error "ill-formed data") ; command ~group ~desc: "ask the node to compute the hash of a data expression \ @@ -804,6 +817,6 @@ let commands () = return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - failwith "ill-formed data") ; + cctxt.error "ill-formed data") ; ] diff --git a/src/client/embedded/alpha/client_proto_programs.mli b/src/client/embedded/alpha/client_proto_programs.mli index d74da2070..2ff6d1df9 100644 --- a/src/client/embedded/alpha/client_proto_programs.mli +++ b/src/client/embedded/alpha/client_proto_programs.mli @@ -18,6 +18,8 @@ val parse_data_type: string -> Script.expr parsed tzresult Lwt.t val print_storage: Format.formatter -> Script.storage -> unit +val report_errors: Client_commands.context -> error list -> unit Lwt.t + module Program : Client_aliases.Alias with type t = Script.code parsed val commands: unit -> Client_commands.command list diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index 301715757..78a7af5d3 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -22,6 +22,7 @@ type error += Quota_exceeded type error += Overflow of Script.location type error += Reject of Script.location type error += Division_by_zero of Script.location +type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error let () = let open Data_encoding in @@ -56,11 +57,28 @@ let () = register_error_kind `Temporary ~id:"scriptRejectedRuntimeError" - ~title: "Script rejected (runtime script error)" - ~description: "" + ~title: "Script failed (runtime script error)" + ~description: "A FAIL instruction was reached" (obj1 (req "location" Script.location_encoding)) (function Reject loc -> Some loc | _ -> None) - (fun loc -> Reject loc) + (fun loc -> Reject loc); + register_error_kind + `Temporary + ~id:"scriptRuntimeError" + ~title: "Script runtime error" + ~description: "Toplevel error for all runtime script errors" + (obj5 + (req "contractHandle" Contract.encoding) + (req "contractCode" Script.expr_encoding) + (req "contractParameterType" ex_ty_enc) + (req "contractReturnType" ex_ty_enc) + (req "contractStorageType" ex_ty_enc)) + (function + | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) -> + Some (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) + | _ -> None) + (fun (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) -> + Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty)); (* ---- interpreter ---------------------------------------------------------*) @@ -519,7 +537,9 @@ and execute ?log origination orig source ctxt storage script amount arg qta = (parse_lambda ~storage_type ctxt arg_type_full ret_type_full code) >>=? fun lambda -> parse_data ctxt arg_type arg >>=? fun arg -> parse_data ctxt storage_type storage >>=? fun storage -> - interp ?log origination qta orig source amount ctxt lambda (arg, storage) + trace + (Runtime_contract_error (source, code, arg_type, ret_type_full, storage_type)) + (interp ?log origination qta orig source amount ctxt lambda (arg, storage)) >>=? fun (ret, qta, ctxt, origination) -> let ret, storage = ret in return (unparse_data storage_type storage, diff --git a/src/proto/alpha/script_interpreter.mli b/src/proto/alpha/script_interpreter.mli index df7413e04..5d8faa92b 100644 --- a/src/proto/alpha/script_interpreter.mli +++ b/src/proto/alpha/script_interpreter.mli @@ -8,11 +8,13 @@ (**************************************************************************) open Tezos_context +open Script_typed_ir type error += Quota_exceeded type error += Overflow of Script.location type error += Reject of Script.location type error += Division_by_zero of Script.location +type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error val dummy_code_fee : Tez.t val dummy_storage_fee : Tez.t diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index 7a4d4d388..4277c6b83 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -1433,14 +1433,24 @@ let parse_script = fun ?type_logger ctxt { storage; storage_type = init_storage_type } { code; arg_type; ret_type; storage_type } -> - (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> - (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> - (Lwt.return (parse_ty init_storage_type)) >>=? fun (Ex_ty init_storage_type) -> - (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> + trace + (Ill_formed_type (Some "parameter", arg_type)) + (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> + trace + (Ill_formed_type (Some "return", ret_type)) + (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> + trace + (Ill_formed_type (Some "initial storage", init_storage_type)) + (Lwt.return (parse_ty init_storage_type)) >>=? fun (Ex_ty init_storage_type) -> + trace + (Ill_formed_type (Some "storage", storage_type)) + (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_type_full = Pair_t (arg_type, storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in Lwt.return (ty_eq init_storage_type storage_type) >>=? fun (Eq _) -> - parse_data ?type_logger ctxt storage_type storage >>=? fun storage -> + trace + (Ill_typed_data (None, storage, storage_type)) + (parse_data ?type_logger ctxt storage_type storage) >>=? fun storage -> trace (Ill_typed_contract (code, arg_type, ret_type, storage_type, [])) (parse_lambda ctxt ~storage_type ?type_logger arg_type_full ret_type_full code) >>=? fun code -> @@ -1573,6 +1583,15 @@ let typecheck_data (* ---- Error registration --------------------------------------------------*) +let ex_ty_enc = + Data_encoding.conv + (fun (Ex_ty ty) -> unparse_ty ty) + (fun expr -> + match parse_ty expr with + | Ok (Ex_ty ty) -> Ex_ty ty + | _ -> Ex_ty Unit_t (* FIXME: ? *)) + Script.expr_encoding + let () = let open Data_encoding in let located enc = @@ -1602,14 +1621,6 @@ let () = "string", String_kind ; "primitiveApplication", Prim_kind ; "sequence", Seq_kind ] in - let ex_ty_enc = - conv - (fun (Ex_ty ty) -> unparse_ty ty) - (fun expr -> - match parse_ty expr with - | Ok (Ex_ty ty) -> Ex_ty ty - | _ -> Ex_ty Unit_t (* FIXME: ? *)) - Script.expr_encoding in let ex_stack_ty_enc = let rec unfold = function | Ex_stack_ty (Item_t (ty, rest)) -> @@ -1671,7 +1682,7 @@ let () = ~id:"invalidExpressionKindTypeError" ~title: "Invalid expression kind (typechecking error)" ~description: - "In a ascript or data expression, an expression was of the wrong kind \ + "In a script or data expression, an expression was of the wrong kind \ (for instance a string where only a primitive applications can appear)." (located (obj2 (req "expectedKinds" (list kind_enc)) @@ -1686,7 +1697,7 @@ let () = ~id:"invalidPrimitiveNamespaceTypeError" ~title: "Invalid primitive namespace (typechecking error)" ~description: - "In a ascript or data expression, a primitive was of the wrong namespace." + "In a script or data expression, a primitive was of the wrong namespace." (located (obj3 (req "primitiveName" string) (req "expectedNamespace" namespace_enc) diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index ebf425b41..e0183c861 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -378,7 +378,7 @@ let () = | Unclassified msg -> Some msg | error -> let msg = Obj.(extension_name @@ extension_constructor error) in - Some ("Unclassified error: " ^ msg ^ ".") in + Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in let title = "Generic error" in let description = "An unclassified error" in let encoding_case =