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,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 "@,@[<v 2>Originated contracts:@,%a@]"
+            (Format.pp_print_list Contract.pp) contracts
+    end ;
+    begin match storage with
+      | None -> ()
+      | Some expr ->
+          Format.fprintf ppf "@,@[<hv 2>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 "@,@[<v 2>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
+          "@<v 0>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 ;
+    | Backtracked (Delegation_result, _) ->
-                                    storage ;
+        Format.fprintf ppf
-                                    originated_contracts ;
+          "@<v 0>This delegation was BACKTRACKED,@,\
-                                    storage_size ; paid_storage_size_diff }) ->
+           its expected effects were NOT applied.@]" ;
+    | Applied (Transaction_result _ as tx) ->
         Format.fprintf ppf
           "This transaction was successfully applied" ;
-        begin match originated_contracts with
+        pp_transaction_result tx
-          | [] -> ()
+    | Backtracked (Transaction_result _ as tx, _errs) ->
-          | contracts ->
-              Format.fprintf ppf "@,@[<v 2>Originated contracts:@,%a@]"
-                (Format.pp_print_list Contract.pp) contracts
-        end ;
-        begin match storage with
-          | None -> ()
-          | Some expr ->
-              Format.fprintf ppf "@,@[<hv 2>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"
+          "@<v 0>This transaction was BACKTRACKED,@,\
-          (Z.to_string consumed_gas) ;
+           its expected effects (as follow) were NOT applied.@]" ;
-        begin match balance_updates with
+        pp_transaction_result tx
-          | [] -> ()
+    | Applied (Origination_result _ as op) ->
-          | 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 }) ->
         Format.fprintf ppf
           "This origination was successfully applied" ;
-        begin match originated_contracts with
+        pp_origination_result op
-          | [] -> ()
+    | Backtracked (Origination_result _ as op, _errs) ->
-          | contracts ->
-              Format.fprintf ppf "@,@[<v 2>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"
+          "@<v 0>This origination was BACKTRACKED,@,\
-          (Z.to_string consumed_gas) ;
+           its expected effects (as follow) were NOT applied.@]" ;
-        begin match balance_updates with
+        pp_origination_result op in
-          | [] -> ()
-          | balance_updates ->
-              Format.fprintf ppf
-                "@,Balance updates:@,  %a"
-                pp_balance_updates balance_updates
-        end 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