Commit f1fc7ab5 authored by Benjamin Canou's avatar Benjamin Canou Committed by Grégoire Henry

Michelson: forbid internal operations in parameter and storage

parent 702896f4
......@@ -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
......
......@@ -817,7 +817,6 @@ and counter = Int32.t
type internal_operation = {
source: Contract.contract ;
operation: manager_operation ;
signature: Signature.t option
}
module Operation : sig
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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) ;
......
......@@ -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:
......
......@@ -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)
......
......@@ -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) ->
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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 ;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment