Alpha: add explicit Backtracked case in receipts

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.")

src/proto_alpha/lib_client/operation_result.ml

@@ -140,27 +140,11 @@ 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_result (type kind) ppf (result : kind manager_operation_result) =
+  let pp_transaction_result
-    Format.fprintf ppf "@," ;
+      (Transaction_result { balance_updates ; consumed_gas ;
-    match result with
-    | Skipped _ ->
-        Format.fprintf ppf
-          "This operation was skipped"
-    | Failed (_, _errs) ->
-        Format.fprintf ppf
-          "This operation FAILED."
-    | Applied Reveal_result ->
-        Format.fprintf ppf
-          "This revelation was successfully 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 }) ->
+                            storage_size ; paid_storage_size_diff }) =
-        Format.fprintf ppf
-          "This transaction was successfully applied" ;
     begin match originated_contracts with
       | [] -> ()
       | contracts ->
@@ -192,12 +176,11 @@ let pp_manager_operation_contents_and_result ppf
           Format.fprintf ppf
             "@,Balance updates:@,  %a"
             pp_balance_updates balance_updates
-        end
+    end in
-    | Applied (Origination_result { balance_updates ; consumed_gas ;
+  let pp_origination_result
+      (Origination_result { balance_updates ; consumed_gas ;
                             originated_contracts ;
-                                    storage_size ; paid_storage_size_diff }) ->
+                            storage_size ; paid_storage_size_diff }) =
-        Format.fprintf ppf
-          "This origination was successfully applied" ;
     begin match originated_contracts with
       | [] -> ()
       | contracts ->
@@ -224,6 +207,47 @@ let pp_manager_operation_contents_and_result 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
+    | Skipped _ ->
+        Format.fprintf ppf
+          "This operation was skipped"
+    | Failed (_, _errs) ->
+        Format.fprintf ppf
+          "This operation FAILED."
+    | Applied Reveal_result ->
+        Format.fprintf ppf
+          "This revelation was successfully applied"
+    | Backtracked (Reveal_result, _) ->
+        Format.fprintf ppf
+          "@<v 0>This revelation was BACKTRACKED,@,\
+           its expected effects were NOT applied.@]" ;
+    | Applied Delegation_result ->
+        Format.fprintf ppf
+          "This delegation was successfully applied"
+    | Backtracked (Delegation_result, _) ->
+        Format.fprintf ppf
+          "@<v 0>This delegation was BACKTRACKED,@,\
+           its expected effects were NOT applied.@]" ;
+    | Applied (Transaction_result _ as tx) ->
+        Format.fprintf ppf
+          "This transaction was successfully applied" ;
+        pp_transaction_result tx
+    | Backtracked (Transaction_result _ as tx, _errs) ->
+        Format.fprintf ppf
+          "@<v 0>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" ;
+        pp_origination_result op
+    | Backtracked (Origination_result _ as op, _errs) ->
+        Format.fprintf ppf
+          "@<v 0>This origination was BACKTRACKED,@,\
+           its expected effects (as follow) were NOT applied.@]" ;
+        pp_origination_result op in
   Format.fprintf ppf
     "@[<v 0>@[<v 2>Manager signed operations:@,\
      From: %a@,\

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
+                  (`Failure, Backtracked (operation_results, Some errors), internal_operations_results)
-                     does not drop the receipt while indicating a
-                     storage exhaustion. *)
-                  (`Failure, Failed (manager_kind operation, errors), [])
           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
+  match ctxt_result with
-    | `Failure -> ctxt (* backtracked *)
+  | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results)
-    | `Success ctxt -> ctxt in
+  | `Success ctxt -> Lwt.return (ctxt, results)
-  Lwt.return (ctxt, results)
 
 let apply_contents_list
     (type kind) ctxt mode pred_block baker

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
 

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
 

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