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 b13825d560aba89f0f1579640f38b1fde2729654..4f8b6a5117b8de3113dac91eda70b10a6a336cbe 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -589,6 +589,12 @@ let report_errors ~details ~show_source duplicate value was found:@ @[%a@]" print_expr expr + | Operations_cannot_be_parsed (loc, _) -> + Format.fprintf + ppf + "%aOperations have no concrete syntax so they cannot be parsed." + print_loc + loc | Unordered_set_values (_, expr) -> Format.fprintf ppf diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index ef9977529a7d22609394d1b714270c1a9127deab..28c6976458a88ba45208c7587b404a1aebfeea94 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1887,10 +1887,18 @@ module Scripts = struct let* Normalize_stack.Ex_stack (st_ty, x, st), ctxt = Normalize_stack.parse_stack ctxt ~legacy nodes in - let+ normalized, _ctxt = + let*! res = Normalize_stack.unparse_stack ctxt unparsing_mode st_ty x st in - normalized) ; + match res with + | Ok (normalized, _ctxt) -> return normalized + | Error err as output -> ( + match Environment.wrap_tztrace err with + | Ecoproto_error (Script_tc_errors.Operations_cannot_be_parsed _) + :: _ -> + (* TODO: match the last error instead of the first *) + return stack + | _ -> Lwt.return output)) ; Registration.register0 ~chunked:true S.normalize_script diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index fe7b23dde6fc11e93a4a366c36e658bed580de45..56cfd3d69cacf3b457e31bb108fa77d64ceda3d3 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -571,6 +571,10 @@ module Script : sig | D_Unit | D_Ticket | D_Lambda_rec + | D_Transfer_tokens + | D_Set_delegate + | D_Create_contract + | D_Emit | I_PACK | I_UNPACK | I_BLAKE2B diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 1b370589413ed223ac11c71669e8ca87f0d86a11..d7d5275d81725007f8ce7a13d4c4c070dba3e5c4 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -52,6 +52,10 @@ type prim = | D_Unit | D_Ticket | D_Lambda_rec + | D_Transfer_tokens + | D_Set_delegate + | D_Create_contract + | D_Emit | I_PACK | I_UNPACK | I_BLAKE2B @@ -208,7 +212,8 @@ type namespace = let namespace = function | K_code | K_view | K_parameter | K_storage -> Keyword_namespace | D_Elt | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True - | D_Unit | D_Lambda_rec | D_Ticket -> + | D_Unit | D_Lambda_rec | D_Ticket | D_Transfer_tokens | D_Set_delegate + | D_Create_contract | D_Emit -> Constant_namespace | I_ABS | I_ADD | I_ADDRESS | I_AMOUNT | I_AND | I_APPLY | I_BALANCE | I_BLAKE2B | I_CAR | I_CAST | I_CDR | I_CHAIN_ID | I_CHECK_SIGNATURE @@ -266,6 +271,10 @@ let string_of_prim = function | D_Unit -> "Unit" | D_Ticket -> "Ticket" | D_Lambda_rec -> "Lambda_rec" + | D_Transfer_tokens -> "Transfer_tokens" + | D_Set_delegate -> "Set_delegate" + | D_Create_contract -> "Create_contract" + | D_Emit -> "Emit" | I_PACK -> "PACK" | I_UNPACK -> "UNPACK" | I_BLAKE2B -> "BLAKE2B" @@ -428,6 +437,10 @@ let prim_of_string = | "Unit" -> return D_Unit | "Ticket" -> return D_Ticket | "Lambda_rec" -> return D_Lambda_rec + | "Transfer_tokens" -> return D_Transfer_tokens + | "Set_delegate" -> return D_Set_delegate + | "Create_contract" -> return D_Create_contract + | "Emit" -> return D_Emit | "PACK" -> return I_PACK | "UNPACK" -> return I_UNPACK | "BLAKE2B" -> return I_BLAKE2B @@ -799,8 +812,13 @@ let prim_encoding = ("NAT", I_NAT); (* Alpha_019 addition *) ("Ticket", D_Ticket); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("Transfer_tokens", D_Transfer_tokens); + ("Set_delegate", D_Set_delegate); + ("Create_contract", D_Create_contract); + ("Emit", D_Emit) (* New instructions must be added here, for backward compatibility of the encoding. *) - (* Keep the comment above at the end of the list *) + (* Keep the comment above at the end of the list *); ] let () = diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index 133edfc06799e4abdb5c088d4aa6f0ce6a95e65d..461a4c97cdc8391d9f0c63b02f57bdf06266ae9d 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -64,6 +64,10 @@ type prim = | D_Unit | D_Ticket | D_Lambda_rec + | D_Transfer_tokens + | D_Set_delegate + | D_Create_contract + | D_Emit | I_PACK | I_UNPACK | I_BLAKE2B diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index fc0d0b08a7c3ffbe909095bff2d07ec72d6ccd29..e192ad6e85159027e09d61a10c9748fa56a88dce 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1854,6 +1854,11 @@ let parse_chest ctxt : Script.node -> (Script_timelock.chest * context) tzresult (loc, strip_locations expr, "a valid time-lock chest"))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let default_parse_operation _ctxt expr = + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation. *) + error (Operations_cannot_be_parsed (location expr, strip_locations expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2086,6 +2091,8 @@ let rec parse_data : context -> allow_forged_tickets:bool -> allow_forged_lazy_storage_id:bool -> + parse_operation: + (context -> Script.node -> (Script_typed_ir.operation * context) tzresult) -> (a, ac) ty -> Script.node -> (a * context) tzresult Lwt.t = @@ -2095,6 +2102,7 @@ let rec parse_data : ctxt ~allow_forged_tickets ~allow_forged_lazy_storage_id + ~parse_operation ty script_data -> let open Lwt_result_syntax in @@ -2110,6 +2118,7 @@ let rec parse_data : ctxt ~allow_forged_tickets ~allow_forged_lazy_storage_id + ~parse_operation ty script_data in @@ -2259,10 +2268,8 @@ let rec parse_data : | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr | Signature_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr - | Operation_t, _ -> - (* operations cannot appear in parameters or storage, - the protocol should never parse the bytes of an operation *) - assert false + | Operation_t, expr -> + Lwt.return @@ traced_no_lwt @@ parse_operation ctxt expr | Chain_id_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr | Contract_t (arg_ty, _), expr -> @@ -2985,6 +2992,7 @@ and parse_instr : ctxt ~allow_forged_tickets:false ~allow_forged_lazy_storage_id:false + ~parse_operation:default_parse_operation t d in @@ -5198,6 +5206,7 @@ let parse_storage : ctxt ~allow_forged_tickets ~allow_forged_lazy_storage_id + ~parse_operation:default_parse_operation storage_type (root storage)) @@ -5381,7 +5390,7 @@ include Data_unparser (struct let parse_packable_ty = parse_packable_ty - let parse_data = parse_data + let parse_data = parse_data ~parse_operation:default_parse_operation end) let unparse_code_rec : unparse_code_rec = @@ -5936,6 +5945,7 @@ let parse_data ~elab_conf ctxt ~allow_forged_tickets ~allow_forged_tickets ~allow_forged_lazy_storage_id ~stack_depth:0 + ~parse_operation:default_parse_operation ctxt ty t diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index e7cad561e77d59339a1ec8c4db8603e994ccdd8d..81ce0095961e86125f9b8f152a2fea90b8544aad 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -278,18 +278,181 @@ let unparse_key_hash ~loc ctxt mode k = let+ ctxt = Gas.consume ctxt Unparse_costs.key_hash_readable in (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) -(* Operations are only unparsed during the production of execution traces of - the interpreter. *) -let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = +let unparse_option_result ~loc unparse_v ctxt = + let open Result_syntax in + function + | Some v -> + let+ v, ctxt = unparse_v ctxt v in + (Prim (loc, D_Some, [v], []), ctxt) + | None -> return (Prim (loc, D_None, [], []), ctxt) + +(* Operations are only unparsed in RPCs, in particular during the + production of execution traces of the interpreter. *) +let unparse_operation ~loc ctxt mode {piop; lazy_storage_diff = _} = let open Result_syntax in let iop = Apply_internal_results.packed_internal_operation piop in - let bytes = - Data_encoding.Binary.to_bytes_exn - Apply_internal_results.internal_operation_encoding - iop - in - let+ ctxt = Gas.consume ctxt (Unparse_costs.operation bytes) in - (Bytes (loc, bytes), ctxt) + match mode with + | Optimized | Optimized_legacy -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Apply_internal_results.internal_operation_encoding + iop + in + let+ ctxt = Gas.consume ctxt (Unparse_costs.operation bytes) in + (Bytes (loc, bytes), ctxt) + | Readable -> + let transfer_tokens ~params ~amount ~dest ctxt = + ("Transfer_tokens", [params; amount; dest], ctxt) + in + let (Internal_operation op) = piop in + let+ name, args, ctxt = + match op.operation with + | Transaction_to_implicit {destination; amount} -> + let* amount, ctxt = unparse_mutez ~loc ctxt amount in + let+ destination, ctxt = + unparse_address + ~loc + ctxt + Readable + { + destination = Contract (Implicit destination); + entrypoint = Entrypoint.default; + } + in + transfer_tokens + ~params:(Prim (loc, D_Unit, [], [])) + ~amount + ~dest:destination + ctxt + | Transaction_to_implicit_with_ticket + {destination; ticket_ty = _; ticket = _; unparsed_ticket; amount} -> + let* unparsed_ticket, ctxt = + Script.force_decode_in_context + ~consume_deserialization_gas:Always + ctxt + unparsed_ticket + in + let* amount, ctxt = unparse_mutez ~loc ctxt amount in + let+ destination, ctxt = + unparse_address + ~loc + ctxt + Readable + { + destination = Contract (Implicit destination); + entrypoint = Entrypoint.default; + } + in + transfer_tokens + ~params:(root unparsed_ticket) + ~amount + ~dest:destination + ctxt + | Transaction_to_sc_rollup + { + destination; + entrypoint; + parameters_ty = _; + parameters = _; + unparsed_parameters; + } -> + let+ destination, ctxt = + unparse_address + ~loc + ctxt + Readable + {destination = Sc_rollup destination; entrypoint} + in + transfer_tokens + ~params:(root unparsed_parameters) + ~amount:(Int (loc, Z.zero)) + ~dest:destination + ctxt + | Transaction_to_zk_rollup + { + destination; + parameters_ty = _; + parameters = _; + unparsed_parameters; + } -> + let+ destination, ctxt = + unparse_address + ~loc + ctxt + Readable + { + destination = Zk_rollup destination; + entrypoint = Entrypoint.default; + } + in + transfer_tokens + ~params:(root unparsed_parameters) + ~amount:(Int (loc, Z.zero)) + ~dest:destination + ctxt + | Transaction_to_smart_contract + { + amount; + location = _; + parameters_ty = _; + parameters = _; + unparsed_parameters; + entrypoint; + destination; + } -> + let* amount, ctxt = unparse_mutez ~loc ctxt amount in + let+ destination, ctxt = + unparse_address + ~loc + ctxt + Readable + {destination = Contract (Originated destination); entrypoint} + in + transfer_tokens + ~params:(root unparsed_parameters) + ~amount + ~dest:destination + ctxt + | Event {ty; tag; unparsed_data} -> + let tag = String (loc, Entrypoint.to_string tag) in + return ("Event", [root ty; tag; root unparsed_data], ctxt) + | Origination + { + delegate; + code; + unparsed_storage; + credit; + preorigination = _; + storage_type = _; + storage = _; + } -> + let* delegate, ctxt = + unparse_option_result + ~loc + (fun ctxt -> unparse_key_hash ~loc ctxt Readable) + ctxt + delegate + in + let+ credit, ctxt = unparse_mutez ~loc ctxt credit in + ( "Create_contract", + [root code; delegate; credit; root unparsed_storage], + ctxt ) + | Delegation delegate -> + let+ delegate, ctxt = + unparse_option_result + ~loc + (fun ctxt -> unparse_key_hash ~loc ctxt Readable) + ctxt + delegate + in + ("Set_delegate", [delegate], ctxt) + in + ( Prim + ( loc, + D_Pair, + (String (loc, name) :: args) @ [Int (loc, Z.of_int op.nonce)], + [] ), + ctxt ) let unparse_chain_id ~loc ctxt mode chain_id = let open Result_syntax in @@ -535,7 +698,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k | Operation_t, operation -> - Lwt.return @@ unparse_operation ~loc ctxt operation + Lwt.return @@ unparse_operation ~loc ctxt mode operation | Chain_id_t, chain_id -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 193607ba1f73262b7159d3280fd72131ba64ccd4..ae858961705709ec804d431ec08803839aadfeba 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -106,10 +106,11 @@ val unparse_bls12_381_fr : [op] and consumes gas from [ctxt]. Useful only for producing execution traces in the interpreter. *) val unparse_operation : - loc:'loc -> + loc:Script.location -> context -> + unparsing_mode -> Script_typed_ir.operation -> - ('loc Script.michelson_node * context, error trace) result + (Script.node * context, error trace) result (** [unparse_with_data_encoding ~loc ctxt v gas_cost enc] returns the bytes representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost] diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index d3e8855e3807ada6bb74f4b4d9e656af1c105af4..f67dc2ff50e6f4f6c48781e6416cb139decb82a4 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -187,6 +187,8 @@ type error += Duplicate_map_keys of Script.location * Script.expr type error += Duplicate_set_values of Script.location * Script.expr +type error += Operations_cannot_be_parsed of Script.location * Script.expr + (* Toplevel errors *) type error += | Ill_typed_data : string option * Script.expr * Script.expr -> error diff --git a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml index a24e2c6545bf560b1f341f8ae8a13c806dbaf606..4c283bcea52bcb99e0c6b4bb542eaddd8021eb9c 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml @@ -341,6 +341,19 @@ let () = (function | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None) (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ; + (* Cannot parse operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.cannot_parse_operation" + ~title:"Operations cannot be parsed" + ~description: + "There is no concrete syntax for operations so they cannot be parsed" + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Operations_cannot_be_parsed (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Operations_cannot_be_parsed (loc, expr)) ; (* -- Instruction typing errors ------------- *) (* Fail not in tail position *) register_error_kind