diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 28465244ae558f60744902a75309e2998b3eb3f0..2cda4d3094d8a60cc76e0124dda4ca9f37fec39a 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018 Nomadic Labs, *) +(* Copyright (c) 2018-2022 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -348,10 +348,28 @@ let estimated_gas_single (type kind) | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_consumed_gas (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (ITransaction_result (Transaction_to_contract_result {consumed_gas; _})) + | Applied + (ITransaction_result + (Transaction_to_tx_rollup_result {consumed_gas; _})) -> + Ok consumed_gas + | Applied (IOrigination_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (IDelegation_result {consumed_gas}) -> Ok consumed_gas + | Skipped _ -> + Ok Gas.Arith.zero (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok Gas.Arith.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in consumed_gas operation_result >>? fun gas -> List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) + internal_consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) gas internal_operation_results @@ -414,10 +432,36 @@ let estimated_storage_single (type kind) ~tx_rollup_origination_size | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_storage_size_diff (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (ITransaction_result + (Transaction_to_contract_result + {paid_storage_size_diff; allocated_destination_contract; _})) -> + if allocated_destination_contract then + Ok (Z.add paid_storage_size_diff origination_size) + else Ok paid_storage_size_diff + | Applied (ITransaction_result (Transaction_to_tx_rollup_result _)) -> + (* TODO: https://gitlab.com/tezos/tezos/-/issues/2339 + Storage fees for transaction rollup. + We need to charge for newly allocated storage (as we do for + Michelson’s big map). *) + Ok Z.zero + | Applied (IOrigination_result {paid_storage_size_diff; _}) -> + Ok (Z.add paid_storage_size_diff origination_size) + | Applied (IDelegation_result _) -> Ok Z.zero + | Skipped _ -> + Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in storage_size_diff operation_result >>? fun storage -> List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) + internal_storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) storage internal_operation_results @@ -480,11 +524,28 @@ let originated_contracts_single (type kind) | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_originated_contracts (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (ITransaction_result + (Transaction_to_contract_result {originated_contracts; _})) -> + Ok originated_contracts + | Applied (ITransaction_result (Transaction_to_tx_rollup_result _)) -> Ok [] + | Applied (IOrigination_result {originated_contracts; _}) -> + Ok originated_contracts + | Applied (IDelegation_result _) -> Ok [] + | Skipped _ -> Ok [] (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok [] (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in originated_contracts operation_result >>? fun contracts -> let contracts = List.rev contracts in List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - originated_contracts r >>? fun contracts -> + internal_originated_contracts r >>? fun contracts -> Ok (List.rev_append contracts acc)) contracts internal_operation_results @@ -530,7 +591,7 @@ let detect_script_failure : type kind. kind operation_metadata -> _ = {operation_result; internal_operation_results; _} : kind Kind.manager contents_result) = let detect_script_failure (type kind) - (result : kind manager_operation_result) = + (result : (kind, _, _) operation_result) = match result with | Applied _ -> Ok () | Skipped _ -> assert false diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index a2bf8f51489d09847cd017df16b6621b39c3c7a8..7f980b5edc515d114fa3e52be254db83a68ee3fe 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -1012,6 +1012,39 @@ let pp_manager_operation_contents_and_result ppf expected effects (as follow) were NOT applied.@]" ; pp_sc_rollup_atomic_batch_result op in + let pp_internal_result (type kind) ppf + (result : kind internal_manager_operation_result) = + Format.fprintf ppf "@," ; + match result with + | Skipped _ -> Format.fprintf ppf "This operation was skipped" + | Failed (_, _errs) -> Format.fprintf ppf "This operation FAILED." + | Applied (IDelegation_result {consumed_gas}) -> + Format.fprintf ppf "This delegation was successfully applied" ; + Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas + | Backtracked (IDelegation_result _, _) -> + Format.fprintf + ppf + "@[This delegation was BACKTRACKED, its expected effects were \ + NOT applied.@]" + | Applied (ITransaction_result tx) -> + Format.fprintf ppf "This transaction was successfully applied" ; + pp_transaction_result tx + | Backtracked (ITransaction_result tx, _errs) -> + Format.fprintf + ppf + "@[This transaction was BACKTRACKED, its expected effects (as \ + follow) were NOT applied.@]" ; + pp_transaction_result tx + | Applied (IOrigination_result op_res) -> + Format.fprintf ppf "This origination was successfully applied" ; + pp_origination_result op_res + | Backtracked (IOrigination_result op_res, _errs) -> + Format.fprintf + ppf + "@[This origination was BACKTRACKED, its expected effects (as \ + follow) were NOT applied.@]" ; + pp_origination_result op_res + in Format.fprintf ppf @@ -1047,7 +1080,7 @@ let pp_manager_operation_contents_and_result ppf pp_internal_operation_result ppf (Internal_contents op) - pp_result + pp_internal_result res)) internal_operation_results) ; Format.fprintf ppf "@]" diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 8eb7143843861a81cc01cf23fbad13a49c54fa0f..2c0d94f1b2fe5af3c260bd03e15e8434add70050 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1016,7 +1016,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.update ctxt dst_rollup state >>=? fun ctxt -> let result = - Transaction_result + ITransaction_result (Transaction_to_tx_rollup_result { balance_updates; @@ -1120,7 +1120,7 @@ let apply_internal_manager_operation_content : chain_id:Chain_id.t -> kind Script_typed_ir.manager_operation -> (context - * kind successful_manager_operation_result + * kind successful_internal_manager_operation_result * Script_typed_ir.packed_internal_operation list) tzresult Lwt.t = @@ -1151,7 +1151,8 @@ let apply_internal_manager_operation_content : ~before_operation >|=? fun (ctxt, res, ops) -> ( ctxt, - (Transaction_result res : kind successful_manager_operation_result), + (ITransaction_result res + : kind successful_internal_manager_operation_result), ops ) | Transaction_to_contract { @@ -1175,7 +1176,7 @@ let apply_internal_manager_operation_content : ~mode ~internal:true ~parameter:(Typed_arg (location, parameters_ty, typed_parameters)) - >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops) + >|=? fun (ctxt, res, ops) -> (ctxt, ITransaction_result res, ops) | Transaction_to_tx_rollup {destination; unparsed_parameters = _; parameters_ty; parameters} -> apply_transaction_to_tx_rollup @@ -1208,11 +1209,11 @@ let apply_internal_manager_operation_content : ~credit ~before_operation >|=? fun (ctxt, origination_result, ops) -> - (ctxt, Origination_result origination_result, ops) + (ctxt, IOrigination_result origination_result, ops) | Delegation delegate -> apply_delegation ~ctxt ~source ~delegate ~before_operation >|=? fun (ctxt, consumed_gas, ops) -> - (ctxt, Delegation_result {consumed_gas}, ops) + (ctxt, IDelegation_result {consumed_gas}, ops) let apply_external_manager_operation_content : type kind. @@ -2209,99 +2210,31 @@ let burn_manager_storage_fees : let burn_internal_storage_fees : type kind. context -> - kind successful_manager_operation_result -> + kind successful_internal_manager_operation_result -> storage_limit:Z.t -> payer:public_key_hash -> - (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t = + (context * Z.t * kind successful_internal_manager_operation_result) tzresult + Lwt.t = fun ctxt smopr ~storage_limit ~payer -> let payer = `Contract (Contract.Implicit payer) in match smopr with - | Transaction_result transaction_result -> + | ITransaction_result transaction_result -> burn_transaction_storage_fees ctxt transaction_result ~storage_limit ~payer >|=? fun (ctxt, storage_limit, transaction_result) -> - (ctxt, storage_limit, Transaction_result transaction_result) - | Origination_result origination_result -> + (ctxt, storage_limit, ITransaction_result transaction_result) + | IOrigination_result origination_result -> burn_origination_storage_fees ctxt origination_result ~storage_limit ~payer >|=? fun (ctxt, storage_limit, origination_result) -> - (ctxt, storage_limit, Origination_result origination_result) - | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr) - | Register_global_constant_result ({balance_updates; _} as payload) -> - let consumed = payload.size_of_constant in - Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Register_global_constant_result {payload with balance_updates} ) - | Set_deposits_limit_result _ -> return (ctxt, storage_limit, smopr) - | Tx_rollup_origination_result ({balance_updates; _} as payload) -> - Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer - >>=? fun (ctxt, storage_limit, origination_bus) -> - let balance_updates = origination_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_origination_result {payload with balance_updates} ) - | Tx_rollup_return_bond_result _ | Tx_rollup_remove_commitment_result _ - | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _ - | Tx_rollup_commit_result _ -> - return (ctxt, storage_limit, smopr) - | Transfer_ticket_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = balance_updates @ storage_bus in - return - ( ctxt, - storage_limit, - Transfer_ticket_result {payload with balance_updates} ) - | Tx_rollup_submit_batch_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_submit_batch_result {payload with balance_updates} ) - | Tx_rollup_dispatch_tickets_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_dispatch_tickets_result {payload with balance_updates} ) - | Dal_publish_slot_header_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_originate_result ({size; _} as payload) -> - Fees.burn_sc_rollup_origination_fees ctxt ~storage_limit ~payer size - >>=? fun (ctxt, storage_limit, balance_updates) -> - let result = Sc_rollup_originate_result {payload with balance_updates} in - return (ctxt, storage_limit, result) - | Sc_rollup_add_messages_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_cement_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_publish_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_refute_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_timeout_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_atomic_batch_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Sc_rollup_atomic_batch_result {payload with balance_updates} ) + (ctxt, storage_limit, IOrigination_result origination_result) + | IDelegation_result _ -> return (ctxt, storage_limit, smopr) let apply_manager_contents (type kind) ctxt mode chain_id ~gas_consumed_in_precheck (op : kind Kind.manager contents) : @@ -2624,13 +2557,19 @@ let mark_backtracked results = and mark_internal_operation_results (Internal_manager_operation_result (kind, result)) = Internal_manager_operation_result - (kind, mark_manager_operation_result result) + (kind, mark_internal_manager_operation_result result) and mark_manager_operation_result : type kind. kind manager_operation_result -> kind manager_operation_result = function | (Failed _ | Skipped _ | Backtracked _) as result -> result | Applied (Reveal_result _) as result -> result | Applied result -> Backtracked (result, None) + and mark_internal_manager_operation_result : + type kind. + kind internal_manager_operation_result -> + kind internal_manager_operation_result = function + | (Failed _ | Skipped _ | Backtracked _) as result -> result + | Applied result -> Backtracked (result, None) in mark_contents_list results [@@coq_axiom_with_reason "non-top-level mutual recursion"] diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 401d1393c0105db11110f15a78406c8601bf9ec3..b83e0e45deaa55bb0dddba728db175a38d3e6802 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -259,6 +259,23 @@ type _ successful_manager_operation_result = } -> Kind.sc_rollup_atomic_batch successful_manager_operation_result +type _ successful_internal_manager_operation_result = + | ITransaction_result : + successful_transaction_result + -> Kind.transaction successful_internal_manager_operation_result + | IOrigination_result : + successful_origination_result + -> Kind.origination successful_internal_manager_operation_result + | IDelegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_internal_manager_operation_result + +type packed_successful_internal_manager_operation_result = + | Successful_internal_manager_result : + 'kind successful_internal_manager_operation_result + -> packed_successful_internal_manager_operation_result + let migration_origination_result_to_successful_manager_operation_result ({ balance_updates; @@ -289,22 +306,44 @@ let pack_migration_operation_results results = (migration_origination_result_to_successful_manager_operation_result el)) results -type 'kind manager_operation_result = - | Applied of 'kind successful_manager_operation_result - | Backtracked of - 'kind successful_manager_operation_result * error trace option - | Failed : 'kind Kind.manager * error trace -> 'kind manager_operation_result - | Skipped : 'kind Kind.manager -> 'kind manager_operation_result +(** The result of an operation in the queue. [Skipped] ones should + always be at the tail, and after a single [Failed]. + * The ['kind] parameter is the operation kind (a transaction, an + origination, etc.). + * The ['manager] parameter is the type of manager kinds. + * The ['successful] parameter is the type of successful operations. + The ['kind] parameter is used to make the type a GADT, but ['manager] and + ['successful] are used to share [operation_result] between internal and + external operation results, and are instantiated for each case. *) +type ('kind, 'manager, 'successful) operation_result = + | Applied of 'successful + | Backtracked of 'successful * error trace option + | Failed : + 'manager * error trace + -> ('kind, 'manager, 'successful) operation_result + | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result [@@coq_force_gadt] +type 'kind manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_manager_operation_result ) + operation_result + +type 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_internal_manager_operation_result ) + operation_result + type packed_internal_manager_operation_result = | Internal_manager_operation_result : - 'kind internal_contents * 'kind manager_operation_result + 'kind internal_contents * 'kind internal_manager_operation_result -> packed_internal_manager_operation_result let pack_internal_manager_operation_result (type kind) (internal_op : kind Script_typed_ir.internal_operation) - (manager_op : kind manager_operation_result) = + (manager_op : kind internal_manager_operation_result) = let internal_op = contents_of_internal_operation internal_op in Internal_manager_operation_result (internal_op, manager_op) @@ -1106,7 +1145,7 @@ end type 'kind iselect = packed_internal_manager_operation_result -> - ('kind internal_contents * 'kind manager_operation_result) option + ('kind internal_contents * 'kind internal_manager_operation_result) option module Internal_result = struct open Data_encoding @@ -1259,11 +1298,11 @@ module Internal_manager_result = struct encoding : 'a Data_encoding.t; kind : 'kind Kind.manager; select : - packed_successful_manager_operation_result -> - 'kind successful_manager_operation_result option; - proj : 'kind successful_manager_operation_result -> 'a; - inj : 'a -> 'kind successful_manager_operation_result; - t : 'kind manager_operation_result Data_encoding.t; + packed_successful_internal_manager_operation_result -> + 'kind successful_internal_manager_operation_result option; + proj : 'kind successful_internal_manager_operation_result -> 'a; + inj : 'a -> 'kind successful_internal_manager_operation_result; + t : 'kind internal_manager_operation_result Data_encoding.t; } -> 'kind case @@ -1282,7 +1321,7 @@ module Internal_manager_result = struct match o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( - match select (Successful_manager_result o) with + match select (Successful_internal_manager_result o) with | None -> None | Some o -> Some ((), proj o))) (fun ((), x) -> Applied (inj x)); @@ -1312,7 +1351,7 @@ module Internal_manager_result = struct match o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( - match select (Successful_manager_result o) with + match select (Successful_internal_manager_result o) with | None -> None | Some o -> Some (((), errs), proj o))) (fun (((), errs), x) -> Backtracked (inj x, errs)); @@ -1325,11 +1364,12 @@ module Internal_manager_result = struct ~op_case:Internal_result.transaction_case ~encoding:Manager_result.transaction_contract_variant_cases ~select:(function - | Successful_manager_result (Transaction_result _ as op) -> Some op + | Successful_internal_manager_result (ITransaction_result _ as op) -> + Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) - ~inj:(fun x -> Transaction_result x) + ~proj:(function ITransaction_result x -> x) + ~inj:(fun x -> ITransaction_result x) let[@coq_axiom_with_reason "gadt"] origination_case = make @@ -1344,10 +1384,11 @@ module Internal_manager_result = struct (dft "paid_storage_size_diff" z Z.zero) (opt "lazy_storage_diff" Lazy_storage.encoding)) ~select:(function - | Successful_manager_result (Origination_result _ as op) -> Some op + | Successful_internal_manager_result (IOrigination_result _ as op) -> + Some op | _ -> None) ~proj:(function - | Origination_result + | IOrigination_result { lazy_storage_diff; balance_updates; @@ -1378,7 +1419,7 @@ module Internal_manager_result = struct paid_storage_size_diff, lazy_storage_diff ) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; - Origination_result + IOrigination_result { lazy_storage_diff; balance_updates; @@ -1397,15 +1438,16 @@ module Internal_manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~select:(function - | Successful_manager_result (Delegation_result _ as op) -> Some op + | Successful_internal_manager_result (IDelegation_result _ as op) -> + Some op | _ -> None) ~kind:Kind.Delegation_manager_kind ~proj:(function[@coq_match_with_default] - | Delegation_result {consumed_gas} -> + | IDelegation_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (consumed_gas, consumed_milligas) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; - Delegation_result {consumed_gas = consumed_milligas}) + IDelegation_result {consumed_gas = consumed_milligas}) end let internal_manager_operation_result_encoding : diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index efd00ffc6bd6e4e4f2b50ebaa9978fafef353605..b73211b91b74285b9c34352159fab4850b70abdb 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -131,15 +131,35 @@ and packed_contents_result = | Contents_result : 'kind contents_result -> packed_contents_result (** The result of an operation in the queue. [Skipped] ones should - always be at the tail, and after a single [Failed]. *) -and 'kind manager_operation_result = - | Applied of 'kind successful_manager_operation_result - | Backtracked of - 'kind successful_manager_operation_result * error trace option - | Failed : 'kind Kind.manager * error trace -> 'kind manager_operation_result - | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + always be at the tail, and after a single [Failed]. + * The ['kind] parameter is the operation kind (a transaction, an + origination, etc.). + * The ['manager] parameter is the type of manager kinds. + * The ['successful] parameter is the type of successful operations. + The ['kind] parameter is used to make the type a GADT, but ['manager] and + ['successful] are used to share [operation_result] between internal and + external operation results, and are instantiated for each case. *) +and ('kind, 'manager, 'successful) operation_result = + | Applied of 'successful + | Backtracked of 'successful * error trace option + | Failed : + 'manager * error trace + -> ('kind, 'manager, 'successful) operation_result + | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result [@@coq_force_gadt] +and 'kind manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_manager_operation_result ) + operation_result + +and 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_internal_manager_operation_result ) + operation_result + (** Result of applying a transaction, either internal or external. *) and successful_transaction_result = | Transaction_to_contract_result of { @@ -169,8 +189,7 @@ and successful_origination_result = { paid_storage_size_diff : Z.t; } -(** Result of applying a {!manager_operation_content}, either internal - or external. *) +(** Result of applying an external {!manager_operation_content}. *) and _ successful_manager_operation_result = | Reveal_result : { consumed_gas : Gas.Arith.fp; @@ -306,6 +325,19 @@ and _ successful_manager_operation_result = } -> Kind.sc_rollup_atomic_batch successful_manager_operation_result +(** Result of applying a {!Script_typed_ir.internal_operation}. *) +and _ successful_internal_manager_operation_result = + | ITransaction_result : + successful_transaction_result + -> Kind.transaction successful_internal_manager_operation_result + | IOrigination_result : + successful_origination_result + -> Kind.origination successful_internal_manager_operation_result + | IDelegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_internal_manager_operation_result + and packed_successful_manager_operation_result = | Successful_manager_result : 'kind successful_manager_operation_result @@ -313,7 +345,7 @@ and packed_successful_manager_operation_result = and packed_internal_manager_operation_result = | Internal_manager_operation_result : - 'kind internal_contents * 'kind manager_operation_result + 'kind internal_contents * 'kind internal_manager_operation_result -> packed_internal_manager_operation_result val contents_of_internal_operation : @@ -321,7 +353,7 @@ val contents_of_internal_operation : val pack_internal_manager_operation_result : 'kind Script_typed_ir.internal_operation -> - 'kind manager_operation_result -> + 'kind internal_manager_operation_result -> packed_internal_manager_operation_result val internal_contents_encoding : packed_internal_contents Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index e33ad28ded1831101c231859cd740fb2820e7f31..5daa83bf2b0117d12f27a7d46bfd7ef132b0608c 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -130,7 +130,7 @@ let detect_script_failure : {operation_result; internal_operation_results; _} : kind Kind.manager Apply_results.contents_result) = let detect_script_failure (type kind) - (result : kind manager_operation_result) = + (result : (kind, _, _) operation_result) = match result with | Applied _ -> Ok () | Skipped _ -> assert false diff --git a/src/proto_alpha/lib_tx_rollup/daemon.ml b/src/proto_alpha/lib_tx_rollup/daemon.ml index 547744c32824b0dcde91c92ad8660286e4d37104..ab1daee67c2dc8de913617fbe7317e5ec7a3814b 100644 --- a/src/proto_alpha/lib_tx_rollup/daemon.ml +++ b/src/proto_alpha/lib_tx_rollup/daemon.ml @@ -135,7 +135,7 @@ let extract_messages_from_block block_info rollup_id = | ( Transaction {amount = _; parameters; destination = Tx_rollup dst; entrypoint}, Applied - (Transaction_result + (ITransaction_result (Transaction_to_tx_rollup_result {ticket_hash; _})) ) when Tx_rollup.equal dst rollup_id && Entrypoint.(entrypoint = Tx_rollup.deposit_entrypoint) ->