Michelson: better propagation and printing of errors to the client

This commit is contained in:
Milo Davis 2017-07-25 14:03:49 +02:00 committed by Benjamin Canou
parent df2d6713b5
commit efdf8c74eb
7 changed files with 112 additions and 56 deletions

View File

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

View File

@ -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
"@[<v 2>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
"@[<v 2>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 =
"@[<hov 0>@[<hov 2>Type@ %a@]@ \
@[<hov 2>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") ;
]

View File

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

View File

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

View File

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

View File

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

View File

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