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: val record_paid_storage_space:
context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t
val with_fees_for_storage: val start_counting_storage_fees :
context -> storage_limit:Z.t -> payer:Contract.t -> context -> context
(context -> (context * 'a) tzresult Lwt.t) ->
(context * 'a) tzresult Lwt.t 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 += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `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 apply_internal_manager_operations ctxt mode ~payer ops =
let rec apply ctxt applied worklist = let rec apply ctxt applied worklist =
match worklist with match worklist with
| [] -> Lwt.return (Ok (ctxt, List.rev applied)) | [] -> Lwt.return (`Success ctxt, List.rev applied)
| (Internal_operation | (Internal_operation
({ source ; operation ; nonce } as op)) :: rest -> ({ source ; operation ; nonce } as op)) :: rest ->
begin begin
@ -472,7 +472,7 @@ let apply_internal_manager_operations ctxt mode ~payer ops =
(fun (Internal_operation op) -> (fun (Internal_operation op) ->
Internal_operation_result (op, Skipped (manager_kind op.operation))) Internal_operation_result (op, Skipped (manager_kind op.operation)))
rest in rest in
Lwt.return (Error (List.rev (skipped @ (result :: applied)))) Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
| Ok (ctxt, result, emitted) -> | Ok (ctxt, result, emitted) ->
apply ctxt apply ctxt
(Internal_operation_result (op, Applied result) :: applied) (Internal_operation_result (op, Applied result) :: applied)
@ -505,38 +505,38 @@ let precheck_manager_contents
return ctxt return ctxt
let apply_manager_contents let apply_manager_contents
(type kind) ctxt mode baker (op : kind Kind.manager contents) (type kind) ctxt mode (op : kind Kind.manager contents)
: (context * kind Kind.manager contents_result) tzresult Lwt.t = : ([ `Success of context | `Failure ] *
kind manager_operation_result *
packed_internal_operation_result list) Lwt.t =
let Manager_operation 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 ctxt = Gas.set_limit ctxt gas_limit in
let level = Level.current ctxt in let ctxt = Fees.start_counting_storage_fees ctxt in
Fees.with_fees_for_storage ctxt ~payer:source ~storage_limit begin fun ctxt -> apply_manager_operation_content ctxt mode
apply_manager_operation_content ctxt mode ~source ~payer:source ~internal:false operation >>= function
~source ~payer:source ~internal:false operation >>= begin function | Ok (ctxt, operation_results, internal_operations) -> begin
| Ok (ctxt, operation_results, internal_operations) -> begin apply_internal_manager_operations
apply_internal_manager_operations ctxt mode ~payer:source internal_operations >>= function
ctxt mode ~payer:source internal_operations >>= function | (`Success ctxt, internal_operations_results) ->
| Ok (ctxt, internal_operations_results) -> Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= begin function
return (ctxt, | Ok ctxt ->
(Applied operation_results, internal_operations_results)) Lwt.return
| Error internal_operations_results -> (`Success ctxt, Applied operation_results, internal_operations_results)
return (ctxt (* backtracked *), | Error errors ->
(Applied operation_results, internal_operations_results)) Lwt.return
end (* TODO: maybe have a special kind of failure that
| Error operation_results -> does not drop the receipt while indicating a
return (ctxt (* backtracked *), storage exhaustion. *)
(Failed (manager_kind operation, operation_results), [])) (`Failure, Failed (manager_kind operation, errors), [])
end
| (`Failure, internal_operations_results) ->
Lwt.return
(`Failure, Applied operation_results, internal_operations_results)
end end
end >>=? fun (ctxt, (operation_result, internal_operation_results)) -> | Error errors ->
return (ctxt, Lwt.return
Manager_operation_result (`Failure, Failed (manager_kind operation, errors), [])
{ balance_updates =
cleanup_balance_updates
[ Contract source, Debited fee ;
Rewards (baker, level.cycle), Credited fee ] ;
operation_result ;
internal_operation_results })
let rec mark_skipped let rec mark_skipped
: type kind. : type kind.
@ -574,56 +574,61 @@ let rec precheck_manager_contents_list
precheck_manager_contents ctxt raw_operation op >>=? fun ctxt -> precheck_manager_contents ctxt raw_operation op >>=? fun ctxt ->
precheck_manager_contents_list ctxt raw_operation rest precheck_manager_contents_list ctxt raw_operation rest
let rec apply_manager_contents_list let rec apply_manager_contents_list_rec
: type kind. : type kind.
Alpha_context.t -> Script_ir_translator.unparsing_mode -> Alpha_context.t -> Script_ir_translator.unparsing_mode ->
public_key_hash -> kind Kind.manager contents_list -> 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 -> fun ctxt mode baker contents_list ->
let level = Level.current ctxt in let level = Level.current ctxt in
match contents_list with match contents_list with
| Single (Manager_operation { operation ; source ; fee ; _ } as op) -> begin | Single (Manager_operation { source ; fee ; _ } as op) -> begin
apply_manager_contents ctxt mode baker op >>= function apply_manager_contents ctxt mode op
| Error errors -> >>= fun (ctxt_result, operation_result, internal_operation_results) ->
let result = let result =
Manager_operation_result { Manager_operation_result {
balance_updates = balance_updates =
cleanup_balance_updates cleanup_balance_updates
[ Contract source, Debited fee ; [ Contract source, Debited fee ;
Rewards (baker, level.cycle), Credited fee ] ; Rewards (baker, level.cycle), Credited fee ] ;
operation_result = Failed (manager_kind operation, errors) ; operation_result ;
internal_operation_results = [] internal_operation_results ;
} in } in
Lwt.return (ctxt, Single_result (result)) Lwt.return (ctxt_result, 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))
end end
| Cons (Manager_operation { operation ; source ; fee ; _ } as op, rest) -> | Cons (Manager_operation { source ; fee ; _ } as op, rest) ->
apply_manager_contents ctxt mode baker op >>= function apply_manager_contents ctxt mode op >>= function
| Error errors -> | (`Failure, operation_result, internal_operation_results) ->
let result = let result =
Manager_operation_result { Manager_operation_result {
balance_updates = balance_updates =
cleanup_balance_updates cleanup_balance_updates
[ Contract source, Debited fee ; [ Contract source, Debited fee ;
Rewards (baker, level.cycle), Credited fee ] ; Rewards (baker, level.cycle), Credited fee ] ;
operation_result = Failed (manager_kind operation, errors) ; operation_result ;
internal_operation_results = [] internal_operation_results ;
} in } in
Lwt.return (ctxt, Cons_result (result, mark_skipped baker level rest)) Lwt.return (`Failure, Cons_result (result, mark_skipped baker level rest))
| Ok (ctxt, (Manager_operation_result | (`Success ctxt, operation_result, internal_operation_results) ->
{ operation_result = Applied _ ; _ } as result)) -> let result =
apply_manager_contents_list ctxt mode baker rest >>= fun (ctxt, results) -> Manager_operation_result {
Lwt.return (ctxt, Cons_result (result, results)) balance_updates =
| Ok (ctxt, cleanup_balance_updates
(Manager_operation_result [ Contract source, Debited fee ;
{ operation_result = (Skipped _ | Failed _) ; _ } as result)) -> Rewards (baker, level.cycle), Credited fee ] ;
Lwt.return (ctxt, Cons_result (result, mark_skipped baker level rest)) 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 let apply_contents_list
(type kind) ctxt mode pred_block baker (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 = let record_paid_storage_space c contract =
Contract_storage.used_storage_space c contract >>=? fun size -> 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) -> 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 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 -> Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn ->
return (c, size, to_be_paid, 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 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 let remaining = Z.sub storage_limit storage_space_to_pay in
if Compare.Z.(remaining < Z.zero) then if Compare.Z.(remaining < Z.zero) then
@ -81,8 +81,5 @@ let check_storage_limit c ~storage_limit =
else else
ok () ok ()
let with_fees_for_storage c ~storage_limit ~payer f = let start_counting_storage_fees c =
Lwt.return (Raw_context.init_storage_space_to_pay c) >>=? fun c -> Raw_context.init_storage_space_to_pay c
f c >>=? fun (c, ret) ->
burn_fees_for_storage c ~storage_limit ~payer >>=? fun c ->
return (c, ret)

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: val check_storage_limit:
Raw_context.t -> storage_limit:Z.t -> unit tzresult Raw_context.t -> storage_limit:Z.t -> unit tzresult
val with_fees_for_storage: val start_counting_storage_fees :
Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t -> Raw_context.t
(Raw_context.t -> (Raw_context.t * 'a) tzresult Lwt.t) ->
(Raw_context.t * 'a) tzresult Lwt.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 _ -> | Some _ ->
assert false assert false
| None -> | 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 = let update_storage_space_to_pay ctxt n =
match ctxt.storage_space_to_pay with match ctxt.storage_space_to_pay with
| None -> | None ->
assert false assert false
| Some storage_space_to_pay -> | 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 = let clear_storage_space_to_pay ctxt =
match ctxt.storage_space_to_pay with 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 gas_consumed: since: t -> until: t -> Z.t
val block_gas_level: t -> Z.t val block_gas_level: t -> Z.t
val init_storage_space_to_pay: t -> t tzresult val init_storage_space_to_pay: t -> t
val update_storage_space_to_pay: t -> Z.t -> t tzresult val update_storage_space_to_pay: t -> Z.t -> t
val clear_storage_space_to_pay: t -> t * Z.t val clear_storage_space_to_pay: t -> t * Z.t
type error += Undefined_operation_nonce (* `Permanent *) type error += Undefined_operation_nonce (* `Permanent *)