diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index b721d589f..318c0b926 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -893,10 +893,11 @@ module Fees : sig val record_paid_storage_space: context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t - val with_fees_for_storage: - context -> storage_limit:Z.t -> payer:Contract.t -> - (context -> (context * 'a) tzresult Lwt.t) -> - (context * 'a) tzresult Lwt.t + val start_counting_storage_fees : + context -> context + + val burn_storage_fees: + context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t type error += Cannot_pay_storage_fee (* `Temporary *) type error += Operation_quota_exceeded (* `Temporary *) diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index d82e182d7..e70f6a5b7 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -453,7 +453,7 @@ let apply_manager_operation_content : let apply_internal_manager_operations ctxt mode ~payer ops = let rec apply ctxt applied worklist = match worklist with - | [] -> Lwt.return (Ok (ctxt, List.rev applied)) + | [] -> Lwt.return (`Success ctxt, List.rev applied) | (Internal_operation ({ source ; operation ; nonce } as op)) :: rest -> begin @@ -472,7 +472,7 @@ let apply_internal_manager_operations ctxt mode ~payer ops = (fun (Internal_operation op) -> Internal_operation_result (op, Skipped (manager_kind op.operation))) rest in - Lwt.return (Error (List.rev (skipped @ (result :: applied)))) + Lwt.return (`Failure, List.rev (skipped @ (result :: applied))) | Ok (ctxt, result, emitted) -> apply ctxt (Internal_operation_result (op, Applied result) :: applied) @@ -505,38 +505,38 @@ let precheck_manager_contents return ctxt let apply_manager_contents - (type kind) ctxt mode baker (op : kind Kind.manager contents) - : (context * kind Kind.manager contents_result) tzresult Lwt.t = + (type kind) ctxt mode (op : kind Kind.manager contents) + : ([ `Success of context | `Failure ] * + kind manager_operation_result * + packed_internal_operation_result list) Lwt.t = let Manager_operation - { source ; fee ; operation ; gas_limit ; storage_limit } = op in + { source ; operation ; gas_limit ; storage_limit } = op in let ctxt = Gas.set_limit ctxt gas_limit in - let level = Level.current ctxt in - Fees.with_fees_for_storage ctxt ~payer:source ~storage_limit begin fun ctxt -> - apply_manager_operation_content ctxt mode - ~source ~payer:source ~internal:false operation >>= begin function - | Ok (ctxt, operation_results, internal_operations) -> begin - apply_internal_manager_operations - ctxt mode ~payer:source internal_operations >>= function - | Ok (ctxt, internal_operations_results) -> - return (ctxt, - (Applied operation_results, internal_operations_results)) - | Error internal_operations_results -> - return (ctxt (* backtracked *), - (Applied operation_results, internal_operations_results)) - end - | Error operation_results -> - return (ctxt (* backtracked *), - (Failed (manager_kind operation, operation_results), [])) + let ctxt = Fees.start_counting_storage_fees ctxt in + apply_manager_operation_content ctxt mode + ~source ~payer:source ~internal:false operation >>= function + | Ok (ctxt, operation_results, internal_operations) -> begin + apply_internal_manager_operations + ctxt mode ~payer:source internal_operations >>= function + | (`Success ctxt, internal_operations_results) -> + Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= begin function + | Ok ctxt -> + Lwt.return + (`Success ctxt, Applied operation_results, internal_operations_results) + | Error errors -> + Lwt.return + (* TODO: maybe have a special kind of failure that + does not drop the receipt while indicating a + storage exhaustion. *) + (`Failure, Failed (manager_kind operation, errors), []) + end + | (`Failure, internal_operations_results) -> + Lwt.return + (`Failure, Applied operation_results, internal_operations_results) end - end >>=? fun (ctxt, (operation_result, internal_operation_results)) -> - return (ctxt, - Manager_operation_result - { balance_updates = - cleanup_balance_updates - [ Contract source, Debited fee ; - Rewards (baker, level.cycle), Credited fee ] ; - operation_result ; - internal_operation_results }) + | Error errors -> + Lwt.return + (`Failure, Failed (manager_kind operation, errors), []) let rec mark_skipped : type kind. @@ -574,56 +574,61 @@ let rec precheck_manager_contents_list precheck_manager_contents ctxt raw_operation op >>=? fun ctxt -> precheck_manager_contents_list ctxt raw_operation rest -let rec apply_manager_contents_list +let rec apply_manager_contents_list_rec : type kind. Alpha_context.t -> Script_ir_translator.unparsing_mode -> public_key_hash -> kind Kind.manager contents_list -> - (context * kind Kind.manager contents_result_list) Lwt.t = + ([ `Success of context | `Failure ] * + kind Kind.manager contents_result_list) Lwt.t = fun ctxt mode baker contents_list -> let level = Level.current ctxt in match contents_list with - | Single (Manager_operation { operation ; source ; fee ; _ } as op) -> begin - apply_manager_contents ctxt mode baker op >>= function - | Error errors -> - let result = - Manager_operation_result { - balance_updates = - cleanup_balance_updates - [ Contract source, Debited fee ; - Rewards (baker, level.cycle), Credited fee ] ; - operation_result = Failed (manager_kind operation, errors) ; - internal_operation_results = [] - } in - Lwt.return (ctxt, Single_result (result)) - | Ok (ctxt, (Manager_operation_result - { operation_result = Applied _ ; _ } as result)) -> - Lwt.return (ctxt, Single_result (result)) - | Ok (ctxt, - (Manager_operation_result - { operation_result = (Skipped _ | Failed _) ; _ } as result)) -> - Lwt.return (ctxt, Single_result (result)) + | Single (Manager_operation { source ; fee ; _ } as op) -> begin + apply_manager_contents ctxt mode op + >>= fun (ctxt_result, operation_result, internal_operation_results) -> + let result = + Manager_operation_result { + balance_updates = + cleanup_balance_updates + [ Contract source, Debited fee ; + Rewards (baker, level.cycle), Credited fee ] ; + operation_result ; + internal_operation_results ; + } in + Lwt.return (ctxt_result, Single_result (result)) end - | Cons (Manager_operation { operation ; source ; fee ; _ } as op, rest) -> - apply_manager_contents ctxt mode baker op >>= function - | Error errors -> + | Cons (Manager_operation { source ; fee ; _ } as op, rest) -> + apply_manager_contents ctxt mode op >>= function + | (`Failure, operation_result, internal_operation_results) -> let result = Manager_operation_result { balance_updates = cleanup_balance_updates [ Contract source, Debited fee ; Rewards (baker, level.cycle), Credited fee ] ; - operation_result = Failed (manager_kind operation, errors) ; - internal_operation_results = [] + operation_result ; + internal_operation_results ; } in - Lwt.return (ctxt, Cons_result (result, mark_skipped baker level rest)) - | Ok (ctxt, (Manager_operation_result - { operation_result = Applied _ ; _ } as result)) -> - apply_manager_contents_list ctxt mode baker rest >>= fun (ctxt, results) -> - Lwt.return (ctxt, Cons_result (result, results)) - | Ok (ctxt, - (Manager_operation_result - { operation_result = (Skipped _ | Failed _) ; _ } as result)) -> - Lwt.return (ctxt, Cons_result (result, mark_skipped baker level rest)) + Lwt.return (`Failure, Cons_result (result, mark_skipped baker level rest)) + | (`Success ctxt, operation_result, internal_operation_results) -> + let result = + Manager_operation_result { + balance_updates = + cleanup_balance_updates + [ Contract source, Debited fee ; + Rewards (baker, level.cycle), Credited fee ] ; + operation_result ; + internal_operation_results ; + } in + apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) -> + Lwt.return (ctxt_result, Cons_result (result, results)) + +let apply_manager_contents_list ctxt mode baker contents_list = + apply_manager_contents_list_rec ctxt mode baker contents_list >>= fun (ctxt_result, results) -> + let ctxt = match ctxt_result with + | `Failure -> ctxt (* backtracked *) + | `Success ctxt -> ctxt in + Lwt.return (ctxt, results) let apply_contents_list (type kind) ctxt mode pred_block baker diff --git a/src/proto_alpha/lib_protocol/src/fees_storage.ml b/src/proto_alpha/lib_protocol/src/fees_storage.ml index b18786c75..1c1d0300b 100644 --- a/src/proto_alpha/lib_protocol/src/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/src/fees_storage.ml @@ -50,12 +50,12 @@ let origination_burn c ~payer = let record_paid_storage_space c contract = Contract_storage.used_storage_space c contract >>=? fun size -> Contract_storage.set_paid_storage_space_and_return_fees_to_pay c contract size >>=? fun (to_be_paid, c) -> - Lwt.return (Raw_context.update_storage_space_to_pay c to_be_paid) >>=? fun c -> + let c = Raw_context.update_storage_space_to_pay c to_be_paid in let cost_per_byte = Constants_storage.cost_per_byte c in Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn -> return (c, size, to_be_paid, to_burn) -let burn_fees_for_storage c ~storage_limit ~payer = +let burn_storage_fees c ~storage_limit ~payer = let c, storage_space_to_pay = Raw_context.clear_storage_space_to_pay c in let remaining = Z.sub storage_limit storage_space_to_pay in if Compare.Z.(remaining < Z.zero) then @@ -81,8 +81,5 @@ let check_storage_limit c ~storage_limit = else ok () -let with_fees_for_storage c ~storage_limit ~payer f = - Lwt.return (Raw_context.init_storage_space_to_pay c) >>=? fun c -> - f c >>=? fun (c, ret) -> - burn_fees_for_storage c ~storage_limit ~payer >>=? fun c -> - return (c, ret) +let start_counting_storage_fees c = + Raw_context.init_storage_space_to_pay c diff --git a/src/proto_alpha/lib_protocol/src/fees_storage.mli b/src/proto_alpha/lib_protocol/src/fees_storage.mli index 8250578b3..d21ce12ee 100644 --- a/src/proto_alpha/lib_protocol/src/fees_storage.mli +++ b/src/proto_alpha/lib_protocol/src/fees_storage.mli @@ -22,7 +22,8 @@ val record_paid_storage_space: val check_storage_limit: Raw_context.t -> storage_limit:Z.t -> unit tzresult -val with_fees_for_storage: - Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> - (Raw_context.t -> (Raw_context.t * 'a) tzresult Lwt.t) -> - (Raw_context.t * 'a) tzresult Lwt.t +val start_counting_storage_fees : + Raw_context.t -> Raw_context.t + +val burn_storage_fees: + Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/raw_context.ml b/src/proto_alpha/lib_protocol/src/raw_context.ml index 10f4f5ac8..6d63c60d0 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.ml +++ b/src/proto_alpha/lib_protocol/src/raw_context.ml @@ -185,14 +185,14 @@ let init_storage_space_to_pay ctxt = | Some _ -> assert false | None -> - ok { ctxt with storage_space_to_pay = Some Z.zero } + { ctxt with storage_space_to_pay = Some Z.zero } let update_storage_space_to_pay ctxt n = match ctxt.storage_space_to_pay with | None -> assert false | Some storage_space_to_pay -> - ok { ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay) } + { ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay) } let clear_storage_space_to_pay ctxt = match ctxt.storage_space_to_pay with diff --git a/src/proto_alpha/lib_protocol/src/raw_context.mli b/src/proto_alpha/lib_protocol/src/raw_context.mli index 72039c0d6..105c93d99 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.mli +++ b/src/proto_alpha/lib_protocol/src/raw_context.mli @@ -97,8 +97,8 @@ val gas_level: t -> Gas_limit_repr.t val gas_consumed: since: t -> until: t -> Z.t val block_gas_level: t -> Z.t -val init_storage_space_to_pay: t -> t tzresult -val update_storage_space_to_pay: t -> Z.t -> t tzresult +val init_storage_space_to_pay: t -> t +val update_storage_space_to_pay: t -> Z.t -> t val clear_storage_space_to_pay: t -> t * Z.t type error += Undefined_operation_nonce (* `Permanent *)