From 3106dee82aa85606beb79f0b0a9414ce5281f29d Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Tue, 26 Jun 2018 18:04:19 +0200 Subject: [PATCH] Alpha: add explicit Backtracked case in receipts --- src/proto_alpha/lib_client/injection.ml | 12 ++ .../lib_client/operation_result.ml | 150 ++++++++++-------- src/proto_alpha/lib_protocol/src/apply.ml | 41 ++++- .../src/apply_operation_result.ml | 48 +++++- .../src/apply_operation_result.mli | 1 + .../lib_protocol/test/helpers/incremental.ml | 5 + 6 files changed, 184 insertions(+), 73 deletions(-) diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 2b7200d0b..9728ef073 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -100,6 +100,8 @@ let estimated_gas_single | Applied Reveal_result -> Ok Z.zero | Applied Delegation_result -> Ok Z.zero | Skipped _ -> assert false + | Backtracked (_, None) -> Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Alpha_environment.wrap_error (Error errs) | Failed (_, errs) -> Alpha_environment.wrap_error (Error errs) in List.fold_left (fun acc (Internal_operation_result (_, r)) -> @@ -129,6 +131,8 @@ let estimated_storage_single | Applied Reveal_result -> Ok Z.zero | Applied Delegation_result -> Ok Z.zero | Skipped _ -> assert false + | Backtracked (_, None) -> Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Alpha_environment.wrap_error (Error errs) | Failed (_, errs) -> Alpha_environment.wrap_error (Error errs) in List.fold_left (fun acc (Internal_operation_result (_, r)) -> @@ -161,6 +165,8 @@ let originated_contracts_single | Applied Reveal_result -> Ok [] | Applied Delegation_result -> Ok [] | Skipped _ -> assert false + | Backtracked (_, None) -> Ok [] (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Alpha_environment.wrap_error (Error errs) | Failed (_, errs) -> Alpha_environment.wrap_error (Error errs) in List.fold_left (fun acc (Internal_operation_result (_, r)) -> @@ -194,6 +200,12 @@ let detect_script_failure : match result with | Applied _ -> Ok () | Skipped _ -> assert false + | Backtracked (_, None) -> (* there must be another error for this to happen *) + Ok () + | Backtracked (_, Some errs) -> + record_trace + (failure "The transfer simulation failed.") + (Alpha_environment.wrap_error (Error errs)) | Failed (_, errs) -> record_trace (failure "The transfer simulation failed.") diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index e113ee407..9d314c7df 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -140,6 +140,73 @@ let pp_manager_operation_contents_and_result ppf (Manager_operation { source ; fee ; operation ; counter ; gas_limit ; storage_limit }, Manager_operation_result { balance_updates ; operation_result ; internal_operation_results }) = + let pp_transaction_result + (Transaction_result { balance_updates ; consumed_gas ; + storage ; + originated_contracts ; + storage_size ; paid_storage_size_diff }) = + begin match originated_contracts with + | [] -> () + | contracts -> + Format.fprintf ppf "@,@[Originated contracts:@,%a@]" + (Format.pp_print_list Contract.pp) contracts + end ; + begin match storage with + | None -> () + | Some expr -> + Format.fprintf ppf "@,@[Updated storage:@ %a@]" + Michelson_v1_printer.print_expr expr + end ; + begin if storage_size <> Z.zero then + Format.fprintf ppf + "@,Storage size: %s bytes" + (Z.to_string storage_size) + end ; + begin if paid_storage_size_diff <> Z.zero then + Format.fprintf ppf + "@,Paid storage size diff: %s bytes" + (Z.to_string paid_storage_size_diff) + end ; + Format.fprintf ppf + "@,Consumed gas: %s" + (Z.to_string consumed_gas) ; + begin match balance_updates with + | [] -> () + | balance_updates -> + Format.fprintf ppf + "@,Balance updates:@, %a" + pp_balance_updates balance_updates + end in + let pp_origination_result + (Origination_result { balance_updates ; consumed_gas ; + originated_contracts ; + storage_size ; paid_storage_size_diff }) = + begin match originated_contracts with + | [] -> () + | contracts -> + Format.fprintf ppf "@,@[Originated contracts:@,%a@]" + (Format.pp_print_list Contract.pp) contracts + end ; + begin if storage_size <> Z.zero then + Format.fprintf ppf + "@,Storage size: %s bytes" + (Z.to_string storage_size) + end ; + begin if paid_storage_size_diff <> Z.zero then + Format.fprintf ppf + "@,Paid storage size diff: %s bytes" + (Z.to_string paid_storage_size_diff) + end ; + Format.fprintf ppf + "@,Consumed gas: %s" + (Z.to_string consumed_gas) ; + begin match balance_updates with + | [] -> () + | balance_updates -> + Format.fprintf ppf + "@,Balance updates:@, %a" + pp_balance_updates balance_updates + end in let pp_result (type kind) ppf (result : kind manager_operation_result) = Format.fprintf ppf "@," ; match result with @@ -152,78 +219,35 @@ let pp_manager_operation_contents_and_result ppf | Applied Reveal_result -> Format.fprintf ppf "This revelation was successfully applied" + | Backtracked (Reveal_result, _) -> + Format.fprintf ppf + "@This revelation was BACKTRACKED,@,\ + its expected effects were NOT applied.@]" ; | Applied Delegation_result -> Format.fprintf ppf "This delegation was successfully applied" - | Applied (Transaction_result { balance_updates ; consumed_gas ; - storage ; - originated_contracts ; - storage_size ; paid_storage_size_diff }) -> + | Backtracked (Delegation_result, _) -> + Format.fprintf ppf + "@This delegation was BACKTRACKED,@,\ + its expected effects were NOT applied.@]" ; + | Applied (Transaction_result _ as tx) -> Format.fprintf ppf "This transaction was successfully applied" ; - begin match originated_contracts with - | [] -> () - | contracts -> - Format.fprintf ppf "@,@[Originated contracts:@,%a@]" - (Format.pp_print_list Contract.pp) contracts - end ; - begin match storage with - | None -> () - | Some expr -> - Format.fprintf ppf "@,@[Updated storage:@ %a@]" - Michelson_v1_printer.print_expr expr - end ; - begin if storage_size <> Z.zero then - Format.fprintf ppf - "@,Storage size: %s bytes" - (Z.to_string storage_size) - end ; - begin if paid_storage_size_diff <> Z.zero then - Format.fprintf ppf - "@,Paid storage size diff: %s bytes" - (Z.to_string paid_storage_size_diff) - end ; + pp_transaction_result tx + | Backtracked (Transaction_result _ as tx, _errs) -> Format.fprintf ppf - "@,Consumed gas: %s" - (Z.to_string consumed_gas) ; - begin match balance_updates with - | [] -> () - | balance_updates -> - Format.fprintf ppf - "@,Balance updates:@, %a" - pp_balance_updates balance_updates - end - | Applied (Origination_result { balance_updates ; consumed_gas ; - originated_contracts ; - storage_size ; paid_storage_size_diff }) -> + "@This transaction was BACKTRACKED,@,\ + its expected effects (as follow) were NOT applied.@]" ; + pp_transaction_result tx + | Applied (Origination_result _ as op) -> Format.fprintf ppf "This origination was successfully applied" ; - begin match originated_contracts with - | [] -> () - | contracts -> - Format.fprintf ppf "@,@[Originated contracts:@,%a@]" - (Format.pp_print_list Contract.pp) contracts - end ; - begin if storage_size <> Z.zero then - Format.fprintf ppf - "@,Storage size: %s bytes" - (Z.to_string storage_size) - end ; - begin if paid_storage_size_diff <> Z.zero then - Format.fprintf ppf - "@,Paid storage size diff: %s bytes" - (Z.to_string paid_storage_size_diff) - end ; + pp_origination_result op + | Backtracked (Origination_result _ as op, _errs) -> Format.fprintf ppf - "@,Consumed gas: %s" - (Z.to_string consumed_gas) ; - begin match balance_updates with - | [] -> () - | balance_updates -> - Format.fprintf ppf - "@,Balance updates:@, %a" - pp_balance_updates balance_updates - end in + "@This origination was BACKTRACKED,@,\ + its expected effects (as follow) were NOT applied.@]" ; + pp_origination_result op in Format.fprintf ppf "@[@[Manager signed operations:@,\ From: %a@,\ diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index e70f6a5b7..36635b329 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -525,10 +525,7 @@ let apply_manager_contents (`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), []) + (`Failure, Backtracked (operation_results, Some errors), internal_operations_results) end | (`Failure, internal_operations_results) -> Lwt.return @@ -623,12 +620,40 @@ let rec apply_manager_contents_list_rec apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) -> Lwt.return (ctxt_result, Cons_result (result, results)) +let mark_backtracked results = + let rec mark_contents_list + : type kind. kind Kind.manager contents_result_list -> kind Kind.manager contents_result_list + = function + | Single_result (Manager_operation_result op) -> + Single_result (Manager_operation_result + { balance_updates = + op.balance_updates ; + operation_result = + mark_manager_operation_result op.operation_result ; + internal_operation_results = + List.map mark_internal_operation_results op.internal_operation_results}) + | Cons_result (Manager_operation_result op, rest) -> + Cons_result (Manager_operation_result + { balance_updates = + op.balance_updates ; + operation_result = + mark_manager_operation_result op.operation_result ; + internal_operation_results = + List.map mark_internal_operation_results op.internal_operation_results}, rest) + and mark_internal_operation_results (Internal_operation_result (kind, result)) = + (Internal_operation_result (kind, mark_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 result -> Backtracked (result, None) in + mark_contents_list 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) + match ctxt_result with + | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results) + | `Success ctxt -> Lwt.return (ctxt, results) let apply_contents_list (type kind) ctxt mode pred_block baker diff --git a/src/proto_alpha/lib_protocol/src/apply_operation_result.ml b/src/proto_alpha/lib_protocol/src/apply_operation_result.ml index ea203d6c6..e2e3a5e58 100644 --- a/src/proto_alpha/lib_protocol/src/apply_operation_result.ml +++ b/src/proto_alpha/lib_protocol/src/apply_operation_result.ml @@ -130,6 +130,7 @@ type packed_successful_manager_operation_result = type 'kind manager_operation_result = | Applied of 'kind successful_manager_operation_result + | Backtracked of 'kind successful_manager_operation_result * error list option | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result | Skipped : 'kind Kind.manager -> 'kind manager_operation_result @@ -168,7 +169,7 @@ module Manager_result = struct encoding) (fun o -> match o with - | Skipped _ | Failed _ -> None + | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> match select (Successful_manager_result o) with | None -> None @@ -185,7 +186,22 @@ module Manager_result = struct ~title:"Skipped" (obj1 (req "status" (constant "skipped"))) (function Skipped _ -> Some () | _ -> None) - (fun () -> Skipped kind) + (fun () -> Skipped kind) ; + case (Tag 3) + ~title:"Backtracked" + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (opt "errors" (list error_encoding))) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Applied _ -> None + | Backtracked (o, errs) -> + match select (Successful_manager_result o) with + | None -> None + | Some o -> Some (((), errs), proj o)) + (fun (((), errs), x) -> (Backtracked (inj x, errs))) ; ] in MCase { op_case ; encoding ; kind ; iselect ; select ; proj ; inj ; t } @@ -556,6 +572,15 @@ module Encoding = struct { op with operation_result = Applied res }) | None -> None end + | Contents_result + (Manager_operation_result + ({ operation_result = Backtracked (res, errs) ; _ } as op)) -> begin + match res_case.select (Successful_manager_result res) with + | Some res -> + Some (Manager_operation_result + { op with operation_result = Backtracked (res, errs) }) + | None -> None + end | Contents_result (Manager_operation_result ({ operation_result = Skipped kind ; _ } as op)) -> @@ -802,6 +827,10 @@ let kind_equal { operation = Reveal _ ; _ }, Manager_operation_result { operation_result = Applied Reveal_result ; _ } -> Some Eq + | Manager_operation + { operation = Reveal _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Reveal_result, _) ; _ } -> Some Eq | Manager_operation { operation = Reveal _ ; _ }, Manager_operation_result @@ -817,6 +846,10 @@ let kind_equal { operation = Transaction _ ; _ }, Manager_operation_result { operation_result = Applied (Transaction_result _); _ } -> Some Eq + | Manager_operation + { operation = Transaction _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Transaction_result _, _); _ } -> Some Eq | Manager_operation { operation = Transaction _ ; _ }, Manager_operation_result @@ -832,6 +865,10 @@ let kind_equal { operation = Origination _ ; _ }, Manager_operation_result { operation_result = Applied (Origination_result _); _ } -> Some Eq + | Manager_operation + { operation = Origination _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Origination_result _, _); _ } -> Some Eq | Manager_operation { operation = Origination _ ; _ }, Manager_operation_result @@ -847,6 +884,10 @@ let kind_equal { operation = Delegation _ ; _ }, Manager_operation_result { operation_result = Applied Delegation_result ; _ } -> Some Eq + | Manager_operation + { operation = Delegation _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Delegation_result, _) ; _ } -> Some Eq | Manager_operation { operation = Delegation _ ; _ }, Manager_operation_result @@ -896,6 +937,9 @@ let rec pack_contents_list : | Cons (_, _), Single_result (Manager_operation_result { operation_result = Applied _ ; _}) -> . + | Cons (_, _), + Single_result (Manager_operation_result + { operation_result = Backtracked _ ; _}) -> . | Single _, Cons_result _ -> . end diff --git a/src/proto_alpha/lib_protocol/src/apply_operation_result.mli b/src/proto_alpha/lib_protocol/src/apply_operation_result.mli index 7a9e3cce0..a16ae57d1 100644 --- a/src/proto_alpha/lib_protocol/src/apply_operation_result.mli +++ b/src/proto_alpha/lib_protocol/src/apply_operation_result.mli @@ -81,6 +81,7 @@ and packed_contents_result = 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 list option | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result | Skipped : 'kind Kind.manager -> 'kind manager_operation_result diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 98eff7135..065cade7b 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -94,6 +94,11 @@ let detect_script_failure : match result with | Applied _ -> Ok () | Skipped _ -> assert false + | Backtracked (_, None) -> + (* there must be another error for this to happen *) + Ok () + | Backtracked (_, Some errs) -> + Alpha_environment.wrap_error (Error errs) | Failed (_, errs) -> Alpha_environment.wrap_error (Error errs) in List.fold_left