Michelson: better propagation and printing of errors to the client
This commit is contained in:
parent
df2d6713b5
commit
efdf8c74eb
@ -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
|
||||
|
@ -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") ;
|
||||
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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 =
|
||||
|
Loading…
Reference in New Issue
Block a user