diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index e09deb5e2..9634cebd8 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -49,6 +49,7 @@ let transfer (cctxt : #Proto_alpha.full) Alpha_services.Contract.counter cctxt block source >>=? fun pcounter -> let counter = Int32.succ pcounter in + let parameters = Option.map ~f:Script.lazy_expr parameters in let operations = [Transaction { amount ; parameters ; destination }] in append_reveal cctxt block ~source ~src_pk operations >>=? fun operations -> let contents = @@ -221,6 +222,7 @@ let originate_contract Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result -> Lwt.return (Micheline_parser.no_parsing_error result) >>=? fun { Michelson_v1_parser.expanded = storage } -> + let code = Script.lazy_expr code and storage = Script.lazy_expr storage in let origination = Origination { manager ; delegate ; 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 c127c672c..9919267d9 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -248,6 +248,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = Contract.pp c print_expr expected | Apply.Bad_contract_parameter (c, Some expected, Some argument) -> + let argument = + Option.unopt_exn + (Failure "ill-serialized argument") + (Data_encoding.force_decode argument) in Format.fprintf ppf "@[Contract %a expected an argument of type@, %a@,but received@, %a@]" Contract.pp c diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index aa05ff627..0aa676c65 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -28,6 +28,10 @@ let pp_manager_operation_content ppf source operation internal pp_result result begin match parameters with | None -> () | Some expr -> + let expr = + Option.unopt_exn + (Failure "ill-serialized argument") + (Data_encoding.force_decode expr) in Format.fprintf ppf "@,Parameter: @[%a@]" Michelson_v1_printer.print_expr expr @@ -47,6 +51,14 @@ let pp_manager_operation_content ppf source operation internal pp_result result begin match script with | None -> Format.fprintf ppf "@,No script (accepts all transactions)" | Some { code ; storage } -> + let code = + Option.unopt_exn + (Failure "ill-serialized code") + (Data_encoding.force_decode code) + and storage = + Option.unopt_exn + (Failure "ill-serialized storage") + (Data_encoding.force_decode storage) in Format.fprintf ppf "@,@[Script:@ %a\ @,@[Initial storage:@ %a@]" diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index c6eaa13f3..a74778b82 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -272,16 +272,23 @@ module Script : sig type expr = prim Micheline.canonical + type lazy_expr = expr Data_encoding.lazy_t + + val force_decode : lazy_expr -> expr tzresult + val force_bytes : lazy_expr -> MBytes.t tzresult + val lazy_expr : expr -> lazy_expr + type node = (location, prim) Micheline.node type t = - { code: expr ; - storage: expr } + { code: lazy_expr ; + storage: lazy_expr } val location_encoding: location Data_encoding.t val expr_encoding: expr Data_encoding.t val prim_encoding: prim Data_encoding.t val encoding: t Data_encoding.t + val lazy_expr_encoding: lazy_expr Data_encoding.t end module Constants : sig @@ -788,7 +795,7 @@ and manager_operation = | Reveal of Signature.Public_key.t | Transaction of { amount: Tez.t ; - parameters: Script.expr option ; + parameters: Script.lazy_expr option ; destination: Contract.contract ; } | Origination of { diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index b5abe5bfd..83cbcd79c 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -14,7 +14,7 @@ open Alpha_context type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *) type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *) type error += Duplicate_endorsement of int (* `Branch *) -type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.expr option (* `Permanent *) +type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.lazy_expr option (* `Permanent *) type error += Invalid_endorsement_level type error += Invalid_commitment of { expected: bool } @@ -79,7 +79,7 @@ let () = Data_encoding.(obj3 (req "contract" Contract.encoding) (opt "expectedType" Script.expr_encoding) - (opt "providedArgument" Script.expr_encoding)) + (opt "providedArgument" Script.lazy_expr_encoding)) (function Bad_contract_parameter (c, expected, supplied) -> Some (c, expected, supplied) | _ -> None) (fun (c, expected, supplied) -> Bad_contract_parameter (c, expected, supplied)) ; @@ -404,6 +404,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation = match parameters with | None -> return () | Some arg -> + Lwt.return (Script.force_decode arg) >>=? fun arg -> match Micheline.root arg with | Prim (_, D_Unit, [], _) -> return () @@ -422,16 +423,18 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation = storage_size_diff = 0L } in return (ctxt, result) | Some script -> - Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) -> + Lwt.return (Script.force_decode script.code) >>=? fun code -> + Lwt.return @@ Script_ir_translator.parse_toplevel code >>=? fun (arg_type, _, _) -> let arg_type = Micheline.strip_locations arg_type in begin match parameters, Micheline.root arg_type with | None, Prim (_, T_unit, _, _) -> return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)))) | Some parameters, _ -> + 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 (parameters, arg_type)) >>=? fun ctxt -> - return (ctxt, parameters) + (Script_ir_translator.typecheck_data ctxt ~check_operations:true (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 diff --git a/src/proto_alpha/lib_protocol/src/contract_storage.ml b/src/proto_alpha/lib_protocol/src/contract_storage.ml index 4074f154a..af0966f86 100644 --- a/src/proto_alpha/lib_protocol/src/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/src/contract_storage.ml @@ -309,7 +309,12 @@ let get_script c contract = | Some code, Some storage -> return (c, Some { Script_repr.code ; storage }) | None, Some _ | Some _, None -> failwith "get_script" -let get_storage = Storage.Contract.Storage.get_option +let get_storage ctxt contract = + Storage.Contract.Storage.get_option ctxt contract >>=? function + | (ctxt, None) -> return (ctxt, None) + | (ctxt, Some storage) -> + Lwt.return (Script_repr.force_decode storage) >>=? fun storage -> + return (ctxt, Some storage) let get_counter c contract = Storage.Contract.Counter.get_option c contract >>=? function @@ -370,6 +375,7 @@ let is_spendable c contract = Storage.Contract.Spendable.mem c contract >>= return let update_script_storage c contract storage big_map_diff = + let storage = Script_repr.lazy_expr storage in update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) -> Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) -> Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size -> diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index d2a10120e..f418d17be 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -158,6 +158,8 @@ let () = (code, storage, parameter, amount, contract) -> Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt -> let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in Script_interpreter.execute ctxt ~check_operations:true @@ -172,6 +174,8 @@ let () = (code, storage, parameter, amount, contract) -> Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt -> let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in Script_interpreter.trace ctxt ~check_operations:true @@ -328,6 +332,7 @@ module Forge = struct block ~branch ~source ?sourcePubKey ~counter ~amount ~destination ?parameters ~gas_limit ~storage_limit ~fee ()= + let parameters = Option.map ~f:Script.lazy_expr parameters in operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit Alpha_context.[Transaction { amount ; parameters ; destination }] diff --git a/src/proto_alpha/lib_protocol/src/operation_repr.ml b/src/proto_alpha/lib_protocol/src/operation_repr.ml index 85abd36b7..9039b5fd9 100644 --- a/src/proto_alpha/lib_protocol/src/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/src/operation_repr.ml @@ -82,7 +82,7 @@ and manager_operation = | Reveal of Signature.Public_key.t | Transaction of { amount: Tez_repr.tez ; - parameters: Script_repr.expr option ; + parameters: Script_repr.lazy_expr option ; destination: Contract_repr.contract ; } | Origination of { @@ -131,7 +131,7 @@ module Encoding = struct (req "kind" (constant "transaction")) (req "amount" Tez_repr.encoding) (req "destination" Contract_repr.encoding) - (opt "parameters" Script_repr.expr_encoding) + (opt "parameters" Script_repr.lazy_expr_encoding) let transaction_case tag = case tag ~name:"Transaction" transaction_encoding diff --git a/src/proto_alpha/lib_protocol/src/operation_repr.mli b/src/proto_alpha/lib_protocol/src/operation_repr.mli index fc43f5465..a6886aeab 100644 --- a/src/proto_alpha/lib_protocol/src/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/src/operation_repr.mli @@ -82,7 +82,7 @@ and manager_operation = | Reveal of Signature.Public_key.t | Transaction of { amount: Tez_repr.tez ; - parameters: Script_repr.expr option ; + parameters: Script_repr.lazy_expr option ; destination: Contract_repr.contract ; } | Origination of { diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index c66371cfc..bcf9fc0fd 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -165,7 +165,9 @@ let rec interp let operation = Origination { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; script = Some { code ; storage } ; spendable } in + delegatable ; spendable ; + script = Some { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in logged_return descr (Item ({ source = self ; operation ; signature = None }, Item (contract, rest)), ctxt) in let logged_return : @@ -666,7 +668,7 @@ let rec interp let operation = Transaction { amount ; destination ; - parameters = Some (Micheline.strip_locations p) } in + parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt) | Create_account, Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> @@ -758,8 +760,9 @@ and execute ?log ctxt ~check_operations ~source ~payer ~self script amount arg : parse_script ctxt ~check_operations script >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) -> parse_data ctxt ~check_operations arg_type arg >>=? fun (arg, ctxt) -> + Lwt.return (Script.force_decode script.code) >>=? fun script_code -> trace - (Runtime_contract_error (self, script.code)) + (Runtime_contract_error (self, script_code)) (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) >>=? fun ((ops, sto), ctxt) -> Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) -> 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 e22762230..0d6e27978 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -2267,7 +2267,8 @@ and parse_contract ok (contract, ctxt)) | Some { code ; _ } -> Lwt.return - (parse_toplevel code >>? fun (arg_type, _, _) -> + (Script.force_decode code >>? fun code -> + parse_toplevel code >>? fun (arg_type, _, _) -> parse_ty ~allow_big_map:false arg_type >>? fun (Ex_ty targ, _) -> ty_eq targ arg >>? fun Eq -> let contract : arg typed_contract = (arg, contract) in @@ -2318,6 +2319,8 @@ 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 } -> + 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)) @@ -2348,7 +2351,8 @@ let parse_contract : | _ -> fail (Invalid_contract (loc, contract)) end | Some script -> - Lwt.return @@ parse_toplevel script.code >>=? fun (arg_type, _, _) -> + 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 -> @@ -2468,6 +2472,8 @@ let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) = Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse value_type x) value) :: acc)) [] pairs 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 @@ -2479,4 +2485,5 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) = return (Some bm, ctxt) end >>=? fun (bm, ctxt) -> Lwt.return @@ unparse_data ctxt ty storage >>=? fun (storage, ctxt) -> - return ({ code ; storage = Micheline.strip_locations storage }, bm, ctxt) + return ({ code = Script.lazy_expr code ; + storage = Script.lazy_expr (Micheline.strip_locations storage) }, bm, ctxt) diff --git a/src/proto_alpha/lib_protocol/src/script_repr.ml b/src/proto_alpha/lib_protocol/src/script_repr.ml index 3650aea60..b719e044d 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.ml +++ b/src/proto_alpha/lib_protocol/src/script_repr.ml @@ -13,6 +13,8 @@ let location_encoding = Micheline.canonical_location_encoding type expr = Michelson_v1_primitives.prim Micheline.canonical +type lazy_expr = expr Data_encoding.lazy_t + type node = (location, Michelson_v1_primitives.prim) Micheline.node let expr_encoding = @@ -20,11 +22,44 @@ let expr_encoding = ~variant:"michelson_v1" Michelson_v1_primitives.prim_encoding -type t = { code : expr ; storage : expr } +type error += Lazy_script_decode (* `Permanent *) + +let () = + register_error_kind `Permanent + ~id:"invalid_binary_format" + ~title:"Invalid binary format" + ~description:"Could not deserialize some piece of data \ + from its binary representation" + Data_encoding.empty + (function Lazy_script_decode -> Some () | _ -> None) + (fun () -> Lazy_script_decode) + +let lazy_expr_encoding = + Data_encoding.lazy_encoding expr_encoding + +let lazy_expr expr = + Data_encoding.make_lazy expr_encoding expr + +let force_decode expr = + match Data_encoding.force_decode expr with + | Some v -> ok v + | None -> error Lazy_script_decode + +let force_bytes expr = + match Data_encoding.force_bytes expr with + | bytes -> ok bytes + | exception _ -> error Lazy_script_decode + +type t = { + code : lazy_expr ; + storage : lazy_expr +} let encoding = let open Data_encoding in conv (fun { code ; storage } -> (code, storage)) (fun (code, storage) -> { code ; storage }) - (obj2 (req "code" expr_encoding) (req "storage" expr_encoding)) + (obj2 + (req "code" lazy_expr_encoding) + (req "storage" lazy_expr_encoding)) diff --git a/src/proto_alpha/lib_protocol/src/script_repr.mli b/src/proto_alpha/lib_protocol/src/script_repr.mli index 0a4f855dd..5a23f1e79 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.mli +++ b/src/proto_alpha/lib_protocol/src/script_repr.mli @@ -11,12 +11,24 @@ type location = Micheline.canonical_location type expr = Michelson_v1_primitives.prim Micheline.canonical +type error += Lazy_script_decode (* `Permanent *) + +type lazy_expr = expr Data_encoding.lazy_t + +val force_decode : lazy_expr -> expr tzresult + +val force_bytes : lazy_expr -> MBytes.t tzresult + type node = (location, Michelson_v1_primitives.prim) Micheline.node val location_encoding : location Data_encoding.t val expr_encoding : expr Data_encoding.t -type t = { code : expr ; storage : expr } +val lazy_expr_encoding : lazy_expr Data_encoding.t + +val lazy_expr : expr -> lazy_expr + +type t = { code : lazy_expr ; storage : lazy_expr } val encoding : t Data_encoding.encoding diff --git a/src/proto_alpha/lib_protocol/src/storage.ml b/src/proto_alpha/lib_protocol/src/storage.ml index aa828bd99..04a071b12 100644 --- a/src/proto_alpha/lib_protocol/src/storage.ml +++ b/src/proto_alpha/lib_protocol/src/storage.ml @@ -141,16 +141,16 @@ module Contract = struct Indexed_context.Make_carbonated_map (struct let name = ["code"] end) (Make_carbonated_value(struct - type t = Script_repr.expr - let encoding = Script_repr.expr_encoding + type t = Script_repr.lazy_expr + let encoding = Script_repr.lazy_expr_encoding end)) module Storage = Indexed_context.Make_carbonated_map (struct let name = ["storage"] end) (Make_carbonated_value(struct - type t = Script_repr.expr - let encoding = Script_repr.expr_encoding + type t = Script_repr.lazy_expr + let encoding = Script_repr.lazy_expr_encoding end)) type bigmap_key = Raw_context.t * Contract_repr.t diff --git a/src/proto_alpha/lib_protocol/src/storage.mli b/src/proto_alpha/lib_protocol/src/storage.mli index b97f7c36e..631d2e219 100644 --- a/src/proto_alpha/lib_protocol/src/storage.mli +++ b/src/proto_alpha/lib_protocol/src/storage.mli @@ -164,12 +164,12 @@ module Contract : sig module Code : Indexed_carbonated_data_storage with type key = Contract_repr.t - and type value = Script_repr.expr + and type value = Script_repr.lazy_expr and type t := Raw_context.t module Storage : Indexed_carbonated_data_storage with type key = Contract_repr.t - and type value = Script_repr.expr + and type value = Script_repr.lazy_expr and type t := Raw_context.t (** Current storage space in bytes. diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml index 9d25dd753..524a7d2cc 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml @@ -35,6 +35,7 @@ let manager_full src ?(fee = Tez.zero) ops context gas_limit = let transaction ?parameters amount destination = + let parameters = Option.map ~f:Script.lazy_expr parameters in Transaction { amount ; parameters ; 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 517d23b43..352c3e9f5 100644 --- a/src/proto_alpha/lib_protocol/test/test_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_big_maps.ml @@ -25,7 +25,9 @@ let parse_expr s : Proto_alpha.Alpha_context.Script.expr tzresult = let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t tzresult = parse_expr code_str >>? fun code -> + let code = Proto_alpha.Alpha_context.Script.lazy_expr code in parse_expr storage_str >>? fun storage -> + let storage = Proto_alpha.Alpha_context.Script.lazy_expr storage in ok { Proto_alpha.Alpha_context.Script.code ; storage } let code = {| diff --git a/src/proto_alpha/lib_protocol/test/test_michelson.ml b/src/proto_alpha/lib_protocol/test/test_michelson.ml index abcbcf9a3..bfec2e4d0 100644 --- a/src/proto_alpha/lib_protocol/test/test_michelson.ml +++ b/src/proto_alpha/lib_protocol/test/test_michelson.ml @@ -30,8 +30,8 @@ let parse_param s : Proto_alpha.Alpha_context.Script.expr = let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t = - let code = parse_param code_str in - let storage = parse_param storage_str in + let code = Script_repr.lazy_expr (parse_param code_str) in + let storage = Script_repr.lazy_expr (parse_param storage_str) in let return: Proto_alpha.Alpha_context.Script.t = {code ; storage} in return