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

Alpha: restore semantics of operation sequence failure

Browse Source
This commit is contained in:
Benjamin Canou 2018-06-26 12:25:13 +02:00
parent fad851561b
commit 85b9a58261
6 changed files with 90 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

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

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

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

11
src/proto_alpha/lib_protocol/src/fees_storage.ml
View File

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

9
src/proto_alpha/lib_protocol/src/fees_storage.mli
View File

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

4
src/proto_alpha/lib_protocol/src/raw_context.ml
View File

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

4
src/proto_alpha/lib_protocol/src/raw_context.mli
View File

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