balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Alpha: add explicit Backtracked case in receipts

Browse Source
This commit is contained in:
Benjamin Canou 2018-06-26 18:04:19 +02:00
parent 85b9a58261
commit 3106dee82a
6 changed files with 184 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/proto_alpha/lib_client/injection.ml
View File

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

72
src/proto_alpha/lib_client/operation_result.ml
View File

@ -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) =
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"
| Applied Delegation_result ->
Format.fprintf ppf
"This delegation was successfully applied"
| Applied (Transaction_result { balance_updates ; consumed_gas ;
let pp_transaction_result
(Transaction_result { balance_updates ; consumed_gas ;
storage ;
originated_contracts ;
storage_size ; paid_storage_size_diff }) ->
Format.fprintf ppf
"This transaction was successfully applied" ;
storage_size ; paid_storage_size_diff }) =
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
| Applied (Origination_result { balance_updates ; consumed_gas ;
end in
let pp_origination_result
(Origination_result { balance_updates ; consumed_gas ;
originated_contracts ;
storage_size ; paid_storage_size_diff }) ->
Format.fprintf ppf
"This origination was successfully applied" ;
storage_size ; paid_storage_size_diff }) =
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@,\

41
src/proto_alpha/lib_protocol/src/apply.ml
View File

@ -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

48
src/proto_alpha/lib_protocol/src/apply_operation_result.ml
View File

@ -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

1
src/proto_alpha/lib_protocol/src/apply_operation_result.mli
View File

@ -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

5
src/proto_alpha/lib_protocol/test/helpers/incremental.ml
View File

@ -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