From f1fc7ab5825e31f4e8a4406d88f9d22d2d3cd1e6 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 3 May 2018 18:09:41 +0200 Subject: [PATCH] Michelson: forbid internal operations in parameter and storage --- .../lib_client/michelson_v1_error_reporter.ml | 5 + .../lib_protocol/src/alpha_context.mli | 1 - src/proto_alpha/lib_protocol/src/apply.ml | 13 +- .../lib_protocol/src/helpers_services.ml | 8 +- .../lib_protocol/src/operation_repr.ml | 10 +- .../lib_protocol/src/operation_repr.mli | 1 - .../lib_protocol/src/script_interpreter.ml | 22 +- .../lib_protocol/src/script_interpreter.mli | 2 - .../lib_protocol/src/script_ir_translator.ml | 229 ++++++++---------- .../lib_protocol/src/script_ir_translator.mli | 10 +- .../lib_protocol/src/script_tc_errors.ml | 1 + .../src/script_tc_errors_registration.ml | 14 +- .../test/helpers/helpers_script.ml | 1 - .../lib_protocol/test/test_big_maps.ml | 4 +- 14 files changed, 153 insertions(+), 168 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 9919267d9..08b4cd2b2 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -71,6 +71,7 @@ let collect_error_locations errs = | Invalid_kind (loc, _, _) | Duplicate_field (loc, _) | Unexpected_big_map loc + | Unexpected_operation loc | Fail_not_in_tail_position loc | Undefined_binop (loc, _, _, _) | Undefined_unop (loc, _, _) @@ -192,6 +193,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = Format.fprintf ppf "%abig_map type only allowed on the left of the toplevel storage pair" print_loc loc ; print_trace locations rest + | Alpha_environment.Ecoproto_error (Unexpected_operation loc) :: rest -> + Format.fprintf ppf "%aoperation type forbidden in parameter, storage and constants" + print_loc loc ; + print_trace locations rest | Alpha_environment.Ecoproto_error (Runtime_contract_error (contract, expr)) :: rest -> let parsed = match parsed with diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index d596189bd..a4756a105 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -817,7 +817,6 @@ and counter = Int32.t type internal_operation = { source: Contract.contract ; operation: manager_operation ; - signature: Signature.t option } module Operation : sig diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index 83cbcd79c..22f7083ba 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -433,14 +433,12 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation = Lwt.return (Script.force_decode parameters) >>=? fun arg -> trace (Bad_contract_parameter (destination, Some arg_type, Some parameters)) - (Script_ir_translator.typecheck_data ctxt ~check_operations:true (arg, arg_type)) >>=? fun ctxt -> + (Script_ir_translator.typecheck_data ctxt (arg, arg_type)) >>=? fun ctxt -> return (ctxt, arg) | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None)) end >>=? fun (ctxt, parameter) -> Script_interpreter.execute - ctxt - ~check_operations:(not internal) - ~source ~payer ~self:(destination, script) ~amount ~parameter + ctxt ~source ~payer ~self:(destination, script) ~amount ~parameter >>=? fun { ctxt ; storage ; big_map_diff ; operations } -> Contract.used_storage_space ctxt destination >>=? fun old_size -> Contract.update_script_storage @@ -467,7 +465,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation = begin match script with | None -> return (None, ctxt) | Some script -> - Script_ir_translator.parse_script ctxt ~check_operations:true script >>=? fun (_, ctxt) -> + Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) -> Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff, ctxt) -> return (Some (script, big_map_diff), ctxt) end >>=? fun (script, ctxt) -> @@ -500,10 +498,7 @@ let apply_internal_manager_operations ctxt ~payer ops = let rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (Ok (ctxt, applied)) - | { source ; operation ; - signature = _ (* at this point the signature must have been - checked if the operation has been - deserialized from the outside world *) } as op :: rest -> + | { source ; operation } as op :: rest -> apply_manager_operation_content ctxt ~source ~payer ~internal:true operation >>= function | Error errors -> let result = Internal op, Failed errors in diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index f418d17be..521d4b587 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -162,7 +162,6 @@ let () = let code = Script.lazy_expr code in Script_interpreter.execute ctxt - ~check_operations:true ~source:contract (* transaction initiator *) ~payer:contract (* storage fees payer *) ~self:(contract, { storage ; code }) (* script owner *) @@ -178,7 +177,6 @@ let () = let code = Script.lazy_expr code in Script_interpreter.trace ctxt - ~check_operations:true ~source:contract (* transaction initiator *) ~payer:contract (* storage fees payer *) ~self:(contract, { storage ; code }) (* script owner *) @@ -197,7 +195,7 @@ let () = begin match maybe_gas with | None -> return (Gas.set_unlimited ctxt) | Some gas -> Lwt.return (Gas.set_limit ctxt gas) end >>=? fun ctxt -> - Script_ir_translator.typecheck_data ctxt ~check_operations:true (data, ty) >>=? fun ctxt -> + Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt -> return (Gas.level ctxt) end ; register0 S.hash_data begin fun ctxt () (expr, typ, maybe_gas) -> @@ -205,8 +203,8 @@ let () = begin match maybe_gas with | None -> return (Gas.set_unlimited ctxt) | Some gas -> Lwt.return (Gas.set_limit ctxt gas) end >>=? fun ctxt -> - Lwt.return (parse_ty ~allow_big_map:false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) -> - parse_data ctxt ~check_operations:true typ (Micheline.root expr) >>=? fun (data, ctxt) -> + Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) -> + parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> Lwt.return (Script_ir_translator.hash_data ctxt typ data) >>=? fun (hash, ctxt) -> return (hash, Gas.level ctxt) end ; diff --git a/src/proto_alpha/lib_protocol/src/operation_repr.ml b/src/proto_alpha/lib_protocol/src/operation_repr.ml index 9039b5fd9..de3ec82e6 100644 --- a/src/proto_alpha/lib_protocol/src/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/src/operation_repr.ml @@ -105,7 +105,6 @@ and counter = Int32.t type internal_operation = { source: Contract_repr.contract ; operation: manager_operation ; - signature: Signature.t option } module Encoding = struct @@ -430,12 +429,11 @@ module Encoding = struct let internal_operation_encoding = conv - (fun { source ; operation ; signature } -> ((source, signature), operation)) - (fun ((source, signature), operation) -> { source ; operation ; signature }) + (fun { source ; operation } -> (source, operation)) + (fun (source, operation) -> { source ; operation }) (merge_objs - (obj2 - (req "source" Contract_repr.encoding) - (opt "signature" Signature.encoding)) + (obj1 + (req "source" Contract_repr.encoding)) (union ~tag_size:`Uint8 [ reveal_case (Tag 0) ; transaction_case (Tag 1) ; diff --git a/src/proto_alpha/lib_protocol/src/operation_repr.mli b/src/proto_alpha/lib_protocol/src/operation_repr.mli index a6886aeab..43cde9409 100644 --- a/src/proto_alpha/lib_protocol/src/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/src/operation_repr.mli @@ -135,7 +135,6 @@ val unsigned_operation_encoding: type internal_operation = { source: Contract_repr.contract ; operation: manager_operation ; - signature: Signature.t option } val internal_operation_encoding: diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index fc0979b6a..a92f102aa 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -593,7 +593,7 @@ let rec interp Transaction { amount ; destination ; parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in - logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt) + logged_return (Item ({ source = self ; operation }, rest), ctxt) | Create_account, Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> @@ -602,7 +602,7 @@ let rec interp Origination { credit ; manager ; delegate ; preorigination = Some contract ; delegatable ; script = None ; spendable = true } in - logged_return (Item ({ source = self ; operation ; signature = None }, + logged_return (Item ({ source = self ; operation }, Item (contract, rest)), ctxt) | Implicit_account, Item (key, rest) -> Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> @@ -632,13 +632,13 @@ let rec interp script = Some { code = Script.lazy_expr code ; storage = Script.lazy_expr storage } } in logged_return - (Item ({ source = self ; operation ; signature = None }, + (Item ({ source = self ; operation }, Item (contract, rest)), ctxt) | Set_delegate, Item (delegate, rest) -> Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> let operation = Delegation delegate in - logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt) + logged_return (Item ({ source = self ; operation }, rest), ctxt) | Balance, rest -> Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> Contract.get_balance ctxt self >>=? fun balance -> @@ -685,12 +685,12 @@ let rec interp (* ---- contract handling ---------------------------------------------------*) -and execute ?log ctxt ~check_operations ~source ~payer ~self script amount arg : +and execute ?log ctxt ~source ~payer ~self script amount arg : (Script.expr * internal_operation list * context * Script_typed_ir.ex_big_map option) tzresult Lwt.t = - parse_script ctxt ~check_operations script + parse_script ctxt script >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) -> - parse_data ctxt ~check_operations arg_type arg >>=? fun (arg, ctxt) -> + parse_data ctxt arg_type arg >>=? fun (arg, ctxt) -> Lwt.return (Script.force_decode script.code) >>=? fun script_code -> trace (Runtime_contract_error (self, script_code)) @@ -706,9 +706,9 @@ type execution_result = big_map_diff : Contract.big_map_diff option ; operations : internal_operation list } -let trace ctxt ~check_operations ~source ~payer ~self:(self, script) ~parameter ~amount = +let trace ctxt ~source ~payer ~self:(self, script) ~parameter ~amount = let log = ref [] in - execute ~log ctxt ~check_operations ~source ~payer ~self script amount (Micheline.root parameter) + execute ~log ctxt ~source ~payer ~self script amount (Micheline.root parameter) >>=? fun (storage, operations, ctxt, big_map_diff) -> begin match big_map_diff with | None -> return (None, ctxt) @@ -719,8 +719,8 @@ let trace ctxt ~check_operations ~source ~payer ~self:(self, script) ~parameter let trace = List.rev !log in return ({ ctxt ; storage ; big_map_diff ; operations }, trace) -let execute ctxt ~check_operations ~source ~payer ~self:(self, script) ~parameter ~amount = - execute ctxt ~check_operations ~source ~payer ~self script amount (Micheline.root parameter) +let execute ctxt ~source ~payer ~self:(self, script) ~parameter ~amount = + execute ctxt ~source ~payer ~self script amount (Micheline.root parameter) >>=? fun (storage, operations, ctxt, big_map_diff) -> begin match big_map_diff with | None -> return (None, ctxt) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 4c62a00a0..93dc1caae 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -21,7 +21,6 @@ type execution_result = val execute: Alpha_context.t -> - check_operations: bool -> source: Contract.t -> payer: Contract.t -> self: (Contract.t * Script.t) -> @@ -34,7 +33,6 @@ type execution_trace = val trace: Alpha_context.t -> - check_operations: bool -> source: Contract.t -> payer: Contract.t -> self: (Contract.t * Script.t) -> diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index 598295284..f5547609c 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -933,7 +933,7 @@ let rec parse_comparable_ty | Prim (loc, (T_pair | T_or | T_set | T_map | T_list | T_option | T_lambda | T_unit | T_signature | T_contract), _, _) as expr -> - parse_ty ~allow_big_map:false expr >>? fun (Ex_ty ty, _) -> + parse_ty ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty, _) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace @@ -941,9 +941,11 @@ let rec parse_comparable_ty T_string ; T_mutez ; T_bool ; T_key ; T_key_hash ; T_timestamp ] -and parse_ty - : allow_big_map: bool -> Script.node -> (ex_ty * annot) tzresult - = fun ~allow_big_map node -> +and parse_ty : + allow_big_map: bool -> + allow_operation: bool -> + Script.node -> (ex_ty * annot) tzresult + = fun ~allow_big_map ~allow_operation node -> match node with | Prim (_, T_pair, [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], @@ -952,9 +954,11 @@ and parse_ty begin match args with | [ key_ty ; value_ty ] -> parse_comparable_ty key_ty >>? fun (Ex_comparable_ty key_ty) -> - parse_ty ~allow_big_map:false value_ty >>? fun (Ex_ty value_ty, right_annot) -> + parse_ty ~allow_big_map:false ~allow_operation value_ty + >>? fun (Ex_ty value_ty, right_annot) -> error_unexpected_annot big_map_loc right_annot >>? fun () -> - parse_ty ~allow_big_map:false remaining_storage >>? fun (Ex_ty remaining_storage, remaining_annot) -> + parse_ty ~allow_big_map:false ~allow_operation remaining_storage + >>? fun (Ex_ty remaining_storage, remaining_annot) -> ok (Ex_ty (Pair_t ((Big_map_t (key_ty, value_ty), map_annot), (remaining_storage, remaining_annot))), storage_annot) @@ -982,30 +986,33 @@ and parse_ty ok (Ex_ty Address_t, annot) | Prim (_, T_signature, [], annot) -> ok (Ex_ty Signature_t, annot) - | Prim (_, T_operation, [], annot) -> - ok (Ex_ty Operation_t, annot) + | Prim (loc, T_operation, [], annot) -> + if allow_operation then + ok (Ex_ty Operation_t, annot) + else + error (Unexpected_operation loc) | Prim (loc, T_contract, [ utl ], annot) -> - parse_ty ~allow_big_map:false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl, left_annot) -> error_unexpected_annot loc left_annot >|? fun () -> (Ex_ty (Contract_t tl), annot) | Prim (_, T_pair, [ utl; utr ], annot) -> - parse_ty ~allow_big_map:false utl >>? fun (Ex_ty tl, left_annot) -> - parse_ty ~allow_big_map:false utr >|? fun (Ex_ty tr, right_annot) -> + parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty ~allow_big_map:false ~allow_operation utr >|? fun (Ex_ty tr, right_annot) -> (Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot) | Prim (_, T_or, [ utl; utr ], annot) -> - parse_ty ~allow_big_map:false utl >>? fun (Ex_ty tl, left_annot) -> - parse_ty ~allow_big_map:false utr >|? fun (Ex_ty tr, right_annot) -> + parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty ~allow_big_map:false ~allow_operation utr >|? fun (Ex_ty tr, right_annot) -> (Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot) | Prim (_, T_lambda, [ uta; utr ], annot) -> - parse_ty ~allow_big_map:false uta >>? fun (Ex_ty ta, _) -> - parse_ty ~allow_big_map:false utr >|? fun (Ex_ty tr, _) -> + parse_ty ~allow_big_map:false ~allow_operation uta >>? fun (Ex_ty ta, _) -> + parse_ty ~allow_big_map:false ~allow_operation utr >|? fun (Ex_ty tr, _) -> (Ex_ty (Lambda_t (ta, tr)), annot) | Prim (loc, T_option, [ ut ], annot) -> - parse_ty ~allow_big_map:false ut >>? fun (Ex_ty t, opt_annot) -> + parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t, opt_annot) -> error_unexpected_annot loc annot >|? fun () -> (Ex_ty (Option_t t), opt_annot) | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ~allow_big_map:false ut >>? fun (Ex_ty t, list_annot) -> + parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t, list_annot) -> error_unexpected_annot loc list_annot >>? fun () -> ok (Ex_ty (List_t t), annot) | Prim (_, T_set, [ ut ], annot) -> @@ -1013,7 +1020,7 @@ and parse_ty ok (Ex_ty (Set_t t), annot) | Prim (_, T_map, [ uta; utr ], annot) -> parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> - parse_ty ~allow_big_map:false utr >>? fun (Ex_ty tr, _) -> + parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr, _) -> ok (Ex_ty (Map_t (ta, tr)), annot) | Prim (loc, T_big_map, _, _) -> error (Unexpected_big_map loc) @@ -1047,8 +1054,8 @@ type ex_script = Ex_script : ('a, 'c) script -> ex_script let rec parse_data : type a. ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations: bool -> a ty -> Script.node -> (a * context) tzresult Lwt.t - = fun ?type_logger ctxt ~check_operations ty script_data -> + context -> a ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ty script_data -> Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> let error () = Invalid_constant (location script_data, strip_locations script_data, ty) in @@ -1061,7 +1068,7 @@ let rec parse_data match item with | Prim (_, D_Elt, [ k; v ], _) -> parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> - parse_data ?type_logger ctxt ~check_operations value_type v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt value_type v >>=? fun (v, ctxt) -> begin match last_value with | Some value -> if Compare.Int.(0 <= (compare_comparable key_type value k)) @@ -1189,21 +1196,7 @@ let rec parse_data match Data_encoding.Binary.of_bytes Operation.internal_operation_encoding (MBytes.of_hex (`Hex s)) with - | Some op -> - begin match check_operations, op.signature with - | true, None -> fail (error ()) - | false, _ -> return (op, ctxt) - | true, Some signature -> - let unsigned = - Data_encoding.Binary.to_bytes_exn - Operation.internal_operation_encoding - { op with signature = None } in - Contract.get_manager_key ctxt op.source >>=? fun public_key -> - if Signature.check public_key signature unsigned then - return (op, ctxt) - else - fail (error ()) - end + | Some op -> return (op, ctxt) | None -> raise Not_found with _ -> fail (error ()) @@ -1223,7 +1216,7 @@ let rec parse_data Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> traced @@ (Lwt.return (Contract.of_b58check s)) >>=? fun c -> - parse_contract ctxt ty1 loc c >>=? fun _ -> + parse_contract ctxt loc ty1 c >>=? fun (ctxt, _) -> return ((ty1, c), ctxt) | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) @@ -1231,8 +1224,8 @@ let rec parse_data | Pair_t ((ta, _), (tb, _)), Prim (_, D_Pair, [ va; vb ], _) -> Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ~check_operations ta va >>=? fun (va, ctxt) -> - parse_data ?type_logger ctxt ~check_operations tb vb >>=? fun (vb, ctxt) -> + parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt tb vb >>=? fun (vb, ctxt) -> return ((va, vb), ctxt) | Pair_t _, Prim (loc, D_Pair, l, _) -> fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) @@ -1242,14 +1235,14 @@ let rec parse_data | Union_t ((tl, _), _), Prim (_, D_Left, [ v ], _) -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ~check_operations tl v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) -> return (L v, ctxt) | Union_t _, Prim (loc, D_Left, l, _) -> fail @@ Invalid_arity (loc, D_Left, 1, List.length l) | Union_t (_, (tr, _)), Prim (_, D_Right, [ v ], _) -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ~check_operations tr v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) -> return (R v, ctxt) | Union_t _, Prim (loc, D_Right, l, _) -> fail @@ Invalid_arity (loc, D_Right, 1, List.length l) @@ -1259,14 +1252,14 @@ let rec parse_data | Lambda_t (ta, tr), (Seq _ as script_instr) -> Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> traced @@ - parse_returning Lambda ?type_logger ~check_operations ctxt (ta, Some "@arg") tr script_instr + parse_returning Lambda ?type_logger ctxt (ta, Some "@arg") tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) | Option_t t, Prim (_, D_Some, [ v ], _) -> Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ~check_operations t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> return (Some v, ctxt) | Option_t _, Prim (loc, D_Some, l, _) -> fail @@ Invalid_arity (loc, D_Some, 1, List.length l) @@ -1284,7 +1277,7 @@ let rec parse_data fold_right_s (fun v (rest, ctxt) -> Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> - parse_data ?type_logger ctxt ~check_operations t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> return ((v :: rest), ctxt)) items ([], ctxt) | List_t _, expr -> @@ -1331,16 +1324,15 @@ and parse_comparable_data ?type_logger:(int -> Script.expr list -> Script.expr list -> unit) -> context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> - parse_data ?type_logger ctxt ~check_operations:false (ty_of_comparable_ty ty) script_data + parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data and parse_returning : type arg ret. ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> tc_context -> context -> - check_operations: bool -> - arg ty * annot -> ret ty -> Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt ~check_operations (arg, arg_annot) ret script_instr -> - parse_instr ?type_logger tc_context ctxt ~check_operations + arg ty * annot -> ret ty -> Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt (arg, arg_annot) ret script_instr -> + parse_instr ?type_logger tc_context ctxt script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), gas) -> trace @@ -1357,9 +1349,8 @@ and parse_instr : type bef. ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> tc_context -> context -> - check_operations: bool -> - Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt ~check_operations script_instr stack_ty -> + Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt script_instr stack_ty -> let return : context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> match judgement with @@ -1410,8 +1401,8 @@ and parse_instr (Item_t (w, Item_t (v, rest, cur_top_annot), annot)) | Prim (loc, I_PUSH, [ t ; d ], instr_annot), stack -> - (Lwt.return (parse_ty ~allow_big_map:false t)) >>=? fun (Ex_ty t, _) -> - parse_data ?type_logger ctxt ~check_operations t d >>=? fun (v, ctxt) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false t)) >>=? fun (Ex_ty t, _) -> + parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, instr_annot)) | Prim (loc, I_UNIT, [], instr_annot), @@ -1425,15 +1416,15 @@ and parse_instr (Item_t (Option_t t, rest, instr_annot)) | Prim (loc, I_NONE, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty ~allow_big_map:false t)) >>=? fun (Ex_ty t, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true t)) >>=? fun (Ex_ty t, _) -> typed ctxt loc (Cons_none t) (Item_t (Option_t t, stack, instr_annot)) | Prim (loc, I_IF_NONE, [ bt ; bf ], instr_annot), (Item_t (Option_t t, rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~check_operations bf (Item_t (t, rest, instr_annot)) >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, instr_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } >>=? fun judgement -> @@ -1456,12 +1447,12 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], instr_annot), Item_t (tl, rest, stack_annot) -> - (Lwt.return (parse_ty ~allow_big_map:false tr)) >>=? fun (Ex_ty tr, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tr)) >>=? fun (Ex_ty tr, _) -> typed ctxt loc Left (Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot)) | Prim (loc, I_RIGHT, [ tl ], instr_annot), Item_t (tr, rest, stack_annot) -> - (Lwt.return (parse_ty ~allow_big_map:false tl)) >>=? fun (Ex_ty tl, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tl)) >>=? fun (Ex_ty tl, _) -> typed ctxt loc Right (Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot), @@ -1469,8 +1460,8 @@ and parse_instr check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~check_operations bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } >>=? fun judgement -> @@ -1478,7 +1469,7 @@ and parse_instr (* lists *) | Prim (loc, I_NIL, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty ~allow_big_map:false t)) >>=? fun (Ex_ty t, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true t)) >>=? fun (Ex_ty t, _) -> typed ctxt loc Nil (Item_t (List_t t, stack, instr_annot)) | Prim (loc, I_CONS, [], instr_annot), @@ -1490,9 +1481,9 @@ and parse_instr (Item_t (List_t t, rest, stack_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations bt + parse_instr ?type_logger tc_context ctxt bt (Item_t (t, Item_t (List_t t, rest, stack_annot), instr_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~check_operations bf + parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in @@ -1505,7 +1496,7 @@ and parse_instr | Prim (loc, I_MAP, [ body ], instr_annot), (Item_t (List_t elt, starting_rest, _)) -> check_kind [ Seq_kind ] body >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1521,7 +1512,7 @@ and parse_instr Item_t (List_t elt, rest, _) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1543,7 +1534,7 @@ and parse_instr check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let elt = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt ~check_operations + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1574,14 +1565,14 @@ and parse_instr | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], instr_annot), stack -> (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> - (Lwt.return (parse_ty ~allow_big_map:false tv)) >>=? fun (Ex_ty tv, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tv)) >>=? fun (Ex_ty tv, _) -> typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv), stack, instr_annot)) | Prim (loc, I_MAP, [ body ], instr_annot), Item_t (Map_t (ck, elt), starting_rest, _) -> let k = ty_of_comparable_ty ck in check_kind [ Seq_kind ] body >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations + parse_instr ?type_logger tc_context ctxt body (Item_t (Pair_t ((k, None), (elt, None)), starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1598,7 +1589,7 @@ and parse_instr check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> let key = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt ~check_operations body + parse_instr ?type_logger tc_context ctxt body (Item_t (Pair_t ((key, None), (element_ty, None)), rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1660,7 +1651,7 @@ and parse_instr | Seq (loc, [ single ], annot), stack -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations single + parse_instr ?type_logger tc_context ctxt single stack >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as instr) -> @@ -1676,13 +1667,13 @@ and parse_instr | Seq (loc, hd :: tl, annot), stack -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations hd + parse_instr ?type_logger tc_context ctxt hd stack >>=? begin fun (judgement, ctxt) -> match judgement with | Failed _ -> fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt ~check_operations (Seq (-1, tl, None)) + parse_instr ?type_logger tc_context ctxt (Seq (-1, tl, None)) middle >>=? fun (judgement, ctxt) -> match judgement with | Failed { descr } -> @@ -1697,9 +1688,9 @@ and parse_instr (Item_t (Bool_t, rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations bt + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~check_operations bf + parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in @@ -1708,7 +1699,7 @@ and parse_instr | Prim (loc, I_LOOP, [ body ], _), (Item_t (Bool_t, rest, stack_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations body + parse_instr ?type_logger tc_context ctxt body rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> @@ -1724,7 +1715,7 @@ and parse_instr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, _) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~check_operations body + parse_instr ?type_logger tc_context ctxt body (Item_t (tl, rest, tl_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> trace @@ -1737,10 +1728,10 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), stack -> - (Lwt.return (parse_ty ~allow_big_map:false arg)) >>=? fun (Ex_ty arg, arg_annot) -> - (Lwt.return (parse_ty ~allow_big_map:false ret)) >>=? fun (Ex_ty ret, _) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true arg)) >>=? fun (Ex_ty arg, arg_annot) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true ret)) >>=? fun (Ex_ty ret, _) -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_returning Lambda ?type_logger ctxt ~check_operations + parse_returning Lambda ?type_logger ctxt (arg, default_annot ~default:default_arg_annot arg_annot) ret code >>=? fun (lambda, ctxt) -> typed ctxt loc (Lambda lambda) @@ -1754,7 +1745,7 @@ and parse_instr Item_t (v, rest, stack_annot) -> fail_unexpected_annot loc instr_annot >>=? fun () -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt ~check_operations code + parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt code rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed descr -> typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) @@ -2016,7 +2007,7 @@ and parse_instr (Item_t (Address_t, rest, instr_annot)) | Prim (loc, I_CONTRACT, [ ty ], _), Item_t (Address_t, rest, instr_annot) -> - Lwt.return (parse_ty ~allow_big_map:false ty) >>=? fun (Ex_ty t, annot) -> + Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, annot) -> fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc (Contract t) (Item_t (Option_t (Contract_t t), rest, instr_annot)) @@ -2062,17 +2053,19 @@ and parse_instr Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return (parse_ty ~allow_big_map:false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false arg_type)) + >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return (parse_ty ~allow_big_map:true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type)) + >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in trace (Ill_typed_contract (cannonical_code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger ~check_operations (arg_type_full, None) ret_type_full code_field) >>=? + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> @@ -2212,9 +2205,9 @@ and parse_instr I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SELF ; I_LAMBDA ] and parse_contract - : type arg. context -> arg ty -> Script.location -> Contract.t -> - (arg typed_contract * context) tzresult Lwt.t - = fun ctxt arg loc contract -> + : type arg. context -> Script.location -> arg ty -> Contract.t -> + (context * arg typed_contract) tzresult Lwt.t + = fun ctxt loc arg contract -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract_exists) >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> fail (Invalid_contract (loc, contract)) @@ -2227,15 +2220,15 @@ and parse_contract Lwt.return (ty_eq arg Unit_t >>? fun Eq -> let contract : arg typed_contract = (arg, contract) in - ok (contract, ctxt)) + ok (ctxt, contract)) | Some { code ; _ } -> Lwt.return (Script.force_decode code >>? fun code -> parse_toplevel code >>? fun (arg_type, _, _) -> - parse_ty ~allow_big_map:false arg_type >>? fun (Ex_ty targ, _) -> + parse_ty ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, _) -> ty_eq targ arg >>? fun Eq -> let contract : arg typed_contract = (arg, contract) in - ok (contract, ctxt)) + ok (ctxt, contract)) and parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult @@ -2281,47 +2274,31 @@ and parse_toplevel let parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations:bool -> Script.t -> (ex_script * context) tzresult Lwt.t - = fun ?type_logger ctxt ~check_operations { code ; storage } -> + context -> Script.t -> (ex_script * context) tzresult Lwt.t + = fun ?type_logger ctxt { code ; storage } -> Lwt.return (Script.force_decode code) >>=? fun code -> Lwt.return (Script.force_decode storage) >>=? fun storage -> Lwt.return (parse_toplevel code) >>=? fun (arg_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ~allow_big_map:false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false arg_type)) + >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ~allow_big_map:true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type)) + >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in trace (Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt ~check_operations storage_type (root storage)) >>=? fun (storage, ctxt) -> + (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> trace (Ill_typed_contract (code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger ~check_operations (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) -let parse_contract : - type t. context -> Script.location -> t Script_typed_ir.ty -> Contract.t -> - (context * t Script_typed_ir.typed_contract) tzresult Lwt.t - = fun ctxt loc ty contract -> - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with - | None -> - begin match ty with - | Unit_t -> return (ctxt, (ty, contract)) - | _ -> fail (Invalid_contract (loc, contract)) - end - | Some script -> - Lwt.return (Script.force_decode script.code) >>=? fun code -> - Lwt.return @@ parse_toplevel code >>=? fun (arg_type, _, _) -> - let arg_type = Micheline.strip_locations arg_type in - Lwt.return (parse_ty ~allow_big_map:false (Micheline.root arg_type)) >>=? fun (Ex_ty arg_type, _) -> - Lwt.return (ty_eq ty arg_type) >>=? fun Eq -> - return (ctxt, (ty, contract)) - let typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t = fun ctxt code -> @@ -2330,10 +2307,12 @@ let typecheck_code (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ~allow_big_map:false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false arg_type)) + >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ~allow_big_map:true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type)) + >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in @@ -2342,7 +2321,6 @@ let typecheck_code (Toplevel { storage_type ; param_type = arg_type }) ctxt ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) - ~check_operations: true (arg_type_full, None) ret_type_full code_field in trace (Ill_typed_contract (code, !type_map)) @@ -2351,14 +2329,15 @@ let typecheck_code let typecheck_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations:bool -> Script.expr * Script.expr -> context tzresult Lwt.t - = fun ?type_logger ctxt ~check_operations (data, exp_ty) -> + context -> Script.expr * Script.expr -> context tzresult Lwt.t + = fun ?type_logger ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return (parse_ty ~allow_big_map:true (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) -> + (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false (root exp_ty))) + >>=? fun (Ex_ty exp_ty, _) -> trace (Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt ~check_operations exp_ty (root data)) >>=? fun (_, ctxt) -> + (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> return ctxt let hash_data ctxt typ data = @@ -2386,7 +2365,7 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } = ctxt contract hash >>=? begin function | (ctxt, None) -> return (None, ctxt) | (ctxt, Some value) -> - parse_data ctxt ~check_operations:false value_type + parse_data ctxt value_type (Micheline.root value) >>=? fun (x, ctxt) -> return (Some x, ctxt) end @@ -2439,8 +2418,8 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) = Lwt.return (Script.force_decode code) >>=? fun code -> Lwt.return (Script.force_decode storage) >>=? fun storage -> Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) -> - Lwt.return @@ parse_ty ~allow_big_map:true storage_type >>=? fun (Ex_ty ty, _) -> - parse_data ctxt ~check_operations:true ty + Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty, _) -> + parse_data ctxt ty (Micheline.root storage) >>=? fun (storage, ctxt) -> begin match extract_big_map ty storage with diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index f925ce23e..880fd6a16 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -57,13 +57,15 @@ val ty_eq : val parse_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations: bool -> + context -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t val unparse_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult val parse_ty : - allow_big_map: bool -> Script.node -> + allow_big_map: bool -> + allow_operation: bool -> + Script.node -> (ex_ty * Script_typed_ir.annot) tzresult val unparse_ty : string option -> 'a Script_typed_ir.ty -> Script.node @@ -76,11 +78,11 @@ val typecheck_code : val typecheck_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations:bool ->Script.expr * Script.expr -> context tzresult Lwt.t + context -> Script.expr * Script.expr -> context tzresult Lwt.t val parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> check_operations: bool -> Script.t -> (ex_script * context) tzresult Lwt.t + context -> Script.t -> (ex_script * context) tzresult Lwt.t val parse_contract : context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml index d6d66f784..d4c61836b 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml @@ -27,6 +27,7 @@ type error += Invalid_kind of Script.location * kind list * kind type error += Missing_field of prim type error += Duplicate_field of Script.location * prim type error += Unexpected_big_map of Script.location +type error += Unexpected_operation of Script.location (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index d89b52059..3a44290e7 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -30,7 +30,7 @@ let ex_ty_enc = Data_encoding.conv (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) (fun expr -> - match parse_ty true (root expr) with + match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with | Ok (Ex_ty ty, _) -> Ex_ty ty | _ -> assert false) Script.expr_encoding @@ -176,6 +176,18 @@ let () = (req "loc" location_encoding)) (function Unexpected_big_map loc -> Some loc | _ -> None) (fun loc -> Unexpected_big_map loc) ; + (* Unexpected operation *) + register_error_kind + `Permanent + ~id:"unexpectedOperation" + ~title: "Big map in unauthorized position (type error)" + ~description: + "When parsing script, a operation type was found \ + in the storage or parameter field." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_operation loc -> Some loc | _ -> None) + (fun loc -> Unexpected_operation loc) ; (* -- Value typing errors ---------------------- *) (* Unordered map keys *) register_error_kind diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml index b758b661c..feb90ebde 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml @@ -33,7 +33,6 @@ let execute_code_pred let tc = Contract.init_origination_nonce tc hash in Script_interpreter.execute tc - ~check_operations: true ~source: op.contract ~payer: op.contract ~self: (dst, script) diff --git a/src/proto_alpha/lib_protocol/test/test_big_maps.ml b/src/proto_alpha/lib_protocol/test/test_big_maps.ml index 352c3e9f5..215bdb307 100644 --- a/src/proto_alpha/lib_protocol/test/test_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_big_maps.ml @@ -57,12 +57,12 @@ let expect_big_map tc contract print_key key_type print_data data_type contents debug " - big_map[%a] is not defined (error)" print_key n ; Helpers_assert.fail_msg "Wrong big map contents" | Some data, None -> - Proto_alpha.Script_ir_translator.parse_data tc ~check_operations: false + Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) -> debug " - big_map[%a] = %a (error)" print_key n print_data data ; Helpers_assert.fail_msg "Wrong big map contents" | Some data, Some exp -> - Proto_alpha.Script_ir_translator.parse_data tc ~check_operations: false + Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) -> debug " - big_map[%a] = %a (expected %a)" print_key n print_data data print_data exp ; Helpers_assert.equal data exp ;