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

Alpha: add a type for operation results

Browse Source
This commit is contained in:
Benjamin Canou 2018-04-19 16:32:32 +02:00 committed by Grégoire Henry
parent 18c77318fb
commit 97208fd532
20 changed files with 972 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

365
src/proto_alpha/lib_client/client_proto_context.ml
View File

@ -12,6 +12,7 @@ open Alpha_context
open Tezos_micheline
open Client_proto_contracts
open Client_keys
open Apply_operation_result
let get_balance (rpc : #Proto_alpha.rpc_context) block contract =
Alpha_services.Contract.balance rpc block contract
@ -36,15 +37,17 @@ let parse_expression arg =
(Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression arg))
let pp_internal_operation ppf { source ; operation } =
let pp_manager_operation_content ppf source operation internal pp_result result =
Format.fprintf ppf "@[<v 0>" ;
begin match operation with
| Alpha_context.Transaction { destination ; amount ; parameters } ->
Format.fprintf ppf
"@[<v 2>Transaction:@,\
Of: %a@,\
"@[<v 2>%s:@,\
Amount: %s%a@,\
From: %a@,\
To: %a"
(if internal then "Internal transaction" else "Transaction")
Client_proto_args.tez_sym
Tez.pp amount
Contract.pp source
Contract.pp destination ;
@ -55,21 +58,24 @@ let pp_internal_operation ppf { source ; operation } =
"@,Parameter: @[<v 0>%a@]"
Michelson_v1_printer.print_expr expr
end ;
pp_result ppf result ;
Format.fprintf ppf "@]" ;
| Origination { manager ; delegate ; credit ; spendable ; delegatable ; script } ->
Format.fprintf ppf "@[<v 2>Origination:@,\
Format.fprintf ppf "@[<v 2>%s:@,\
From: %a@,\
For: %a@,\
Credit: %a"
Credit: %s%a"
(if internal then "Internal origination" else "Origination")
Contract.pp source
Signature.Public_key_hash.pp manager
Client_proto_args.tez_sym
Tez.pp credit ;
begin match script with
| None -> Format.fprintf ppf "@,No script (accepts all transactions)"
| Some { code ; storage } ->
Format.fprintf ppf
"@,@[<v 2>Script:@,%a\
@,@[<v 2>Initial storage:@,%a@]"
"@,@[<hv 2>Script:@ %a\
@,@[<hv 2>Initial storage:@ %a@]"
Michelson_v1_printer.print_expr code
Michelson_v1_printer.print_expr storage
end ;
@ -79,30 +85,327 @@ let pp_internal_operation ppf { source ; operation } =
end ;
if spendable then Format.fprintf ppf "@,Spendable by its manager" ;
if delegatable then Format.fprintf ppf "@,Delegate can be changed later" ;
pp_result ppf result ;
Format.fprintf ppf "@]" ;
| Reveal key ->
Format.fprintf ppf
"@[<v 2>Revelation of manager public key:@,\
"@[<v 2>%s of manager public key:@,\
Contract: %a@,\
Key: %a@]"
Key: %a%a@]"
(if internal then "Internal revelation" else "Revelation")
Contract.pp source
Signature.Public_key.pp key
pp_result result
| Delegation None ->
Format.fprintf ppf
"@[<v 2>Delegation:@,\
"@[<v 2>%s:@,\
Contract: %a@,\
To: nobody@]"
To: nobody%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp source
pp_result result
| Delegation (Some delegate) ->
Format.fprintf ppf
"@[<v 2>Delegation:@,\
"@[<v 2>%s:@,\
Contract: %a@,\
To: %a@]"
To: %a%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp source
Signature.Public_key_hash.pp delegate
pp_result result
end ;
Format.fprintf ppf "@]"
let pp_balance_updates ppf = function
| [] -> ()
| balance_updates ->
let balance_updates =
List.map (fun (balance, update) ->
let balance = match balance with
| Contract c ->
Format.asprintf "%a" Contract.pp c
| Rewards (pkh, l) ->
Format.asprintf "rewards(%a,%a)"
Signature.Public_key_hash.pp pkh Cycle.pp l
| Fees (pkh, l) ->
Format.asprintf "fees(%a,%a)"
Signature.Public_key_hash.pp pkh Cycle.pp l
| Deposits (pkh, l) ->
Format.asprintf "deposits(%a,%a)"
Signature.Public_key_hash.pp pkh Cycle.pp l in
(balance, update)) balance_updates in
let column_size =
List.fold_left
(fun acc (balance, _) -> Compare.Int.max acc (String.length balance))
0 balance_updates in
let pp_update ppf = function
| Credited amount -> Format.fprintf ppf "+%s%a" Client_proto_args.tez_sym Tez.pp amount
| Debited amount -> Format.fprintf ppf "-%s%a" Client_proto_args.tez_sym Tez.pp amount in
let pp_one ppf (balance, update) =
let to_fill = column_size + 3 - String.length balance in
let filler = String.make to_fill '.' in
Format.fprintf ppf "%s %s %a" balance filler pp_update update in
Format.fprintf ppf "@[<v 0>%a@]"
(Format.pp_print_list pp_one) balance_updates
let pp_operation_result ppf ({ contents ; _ }, operation_result) =
Format.fprintf ppf "@[<v 0>" ;
begin match contents, operation_result with
| Anonymous_operations ops, Anonymous_operations_result rs ->
let ops_rs = List.combine ops rs in
let pp_anonymous_operation_result ppf = function
| Seed_nonce_revelation { level ; nonce },
Seed_nonce_revelation_result bus ->
Format.fprintf ppf
"@[<v 2>Seed nonce revelation:@,\
Level: %a@,\
Nonce (hash): %a@,\
Balance updates:@,\
\ %a@]"
Raw_level.pp level
Nonce_hash.pp (Nonce.hash nonce)
pp_balance_updates bus
| Double_baking_evidence { bh1 ; bh2 },
Double_baking_evidence_result bus ->
Format.fprintf ppf
"@[<v 2>Double baking evidence:@,\
Exhibit A: %a@,\
Exhibit B: %a@,\
Balance updates:@,\
\ %a@]"
Block_hash.pp (Block_header.hash bh1)
Block_hash.pp (Block_header.hash bh2)
pp_balance_updates bus
| Double_endorsement_evidence { op1 ; op2},
Double_endorsement_evidence_result bus ->
Format.fprintf ppf
"@[<v 2>Double endorsement evidence:@,\
Exhibit A: %a@,\
Exhibit B: %a@,\
Balance updates:@,\
\ %a@]"
Operation_hash.pp (Operation.hash op1)
Operation_hash.pp (Operation.hash op2)
pp_balance_updates bus
| Activation { id ; _ },
Activation_result bus ->
Format.fprintf ppf
"@[<v 2>Genesis account activation:@,\
Account: %a@,\
Balance updates:@,\
\ %a@]"
Ed25519.Public_key_hash.pp id
pp_balance_updates bus
| _, _ -> invalid_arg "Apply_operation_result.pp"
in
Format.pp_print_list pp_anonymous_operation_result ppf ops_rs
| Sourced_operations
(Consensus_operation
(Endorsements { block ; level ; slots })),
Sourced_operation_result
(Consensus_operation_result
(Endorsements_result (delegate, _slots))) ->
Format.fprintf ppf
"@[<v 2>Endorsement:@,\
Block: %a@,\
Level: %a@,\
Delegate: %a@,\
Slots: %a@]"
Block_hash.pp block
Raw_level.pp level
Signature.Public_key_hash.pp delegate
(Format.pp_print_list
~pp_sep:Format.pp_print_space
Format.pp_print_int)
slots
| Sourced_operations
(Amendment_operation { source ; operation = Proposals { period ; proposals } }),
Sourced_operation_result Amendment_operation_result ->
Format.fprintf ppf
"@[<v 2>Proposals:@,\
From: %a@,\
Period: %a@,\
Protocols:@,\
\ @[<v 0>%a@]@]"
Signature.Public_key_hash.pp source
Voting_period.pp period
(Format.pp_print_list Protocol_hash.pp) proposals
| Sourced_operations
(Amendment_operation { source ; operation = Ballot { period ; proposal ; ballot } }),
Sourced_operation_result Amendment_operation_result ->
Format.fprintf ppf
"@[<v 2>Ballot:@,\
From: %a@,\
Period: %a@,\
Protocol: %a@,\
Vote: %s@]"
Signature.Public_key_hash.pp source
Voting_period.pp period
Protocol_hash.pp proposal
(match ballot with Yay -> "YAY" | Pass -> "PASS" | Nay -> "NAY")
| Sourced_operations (Dictator_operation (Activate protocol)),
Sourced_operation_result Dictator_operation_result ->
Format.fprintf ppf
"@[<v 2>Dictator protocol activation:@,\
Protocol: %a@]"
Protocol_hash.pp protocol
| Sourced_operations (Dictator_operation (Activate_testchain protocol)),
Sourced_operation_result Dictator_operation_result ->
Format.fprintf ppf
"@[<v 2>Dictator test protocol activation:@,\
Protocol: %a@]"
Protocol_hash.pp protocol
| Sourced_operations (Manager_operations { source ; fee ; counter ; operations ; gas_limit }),
Sourced_operation_result (Manager_operations_result { balance_updates ; operation_results }) ->
let pp_result ppf result =
Format.fprintf ppf "@," ;
match result with
| Skipped ->
Format.fprintf ppf
"This operation was skipped"
| Failed errs ->
Format.fprintf ppf
"@[<v 2>This operation FAILED with the folllowing error:@,%a@]"
(Format.pp_print_list Alpha_environment.Error_monad.pp) errs
| 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 ;
operations ; storage ;
originated_contracts ; storage_fees_increment }) ->
Format.fprintf ppf
"This transaction was successfully applied" ;
begin match operations with
| [] -> ()
| ops -> Format.fprintf ppf "@,Internal operations: %d" (List.length ops)
end ;
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_fees_increment <> Tez.zero then
Format.fprintf ppf
"@,Storage fees increment: %s%a"
Client_proto_args.tez_sym
Tez.pp storage_fees_increment
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
| Applied (Origination_result { balance_updates ; consumed_gas ;
originated_contracts ; storage_fees_increment }) ->
Format.fprintf ppf
"This transaction was successfully applied:" ;
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_fees_increment <> Tez.zero then
Format.fprintf ppf
"@,Storage fees increment: %s%a"
Client_proto_args.tez_sym
Tez.pp storage_fees_increment
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 rec pp_manager_operations_results ppf = function
| [], [] -> ()
| operation :: ops, (External, r) :: rs ->
Format.fprintf ppf "@," ;
pp_manager_operation_content ppf source operation false pp_result r ;
pp_manager_operations_results ppf (ops, rs)
| ops, (Internal { source ; operation }, r) :: rs ->
Format.fprintf ppf "@," ;
pp_manager_operation_content ppf source operation true pp_result r ;
pp_manager_operations_results ppf (ops, rs)
| [], _ :: _
| _ :: _, [] -> invalid_arg "Apply_operation_result.pp" in
Format.fprintf ppf
"@[<v 0>@[<v 2>Manager signed operations:@,\
From: %a@,\
Fee to the baker: %s%a@,\
Expected counter: %ld@,\
Gas limit: %s"
Contract.pp source
Client_proto_args.tez_sym
Tez.pp fee
counter
(Z.to_string gas_limit) ;
begin match balance_updates with
| [] -> ()
| balance_updates ->
Format.fprintf ppf
"@,Balance updates:@, %a"
pp_balance_updates balance_updates
end ;
Format.fprintf ppf
"@]%a@]"
pp_manager_operations_results (operations, operation_results)
| _, _ -> invalid_arg "Apply_operation_result.pp"
end ;
Format.fprintf ppf "@]"
let pp_internal_operation ppf { source ; operation } =
pp_manager_operation_content ppf source operation true (fun _ppf () -> ()) ()
let estimated_gas = function
| Sourced_operation_result (Manager_operations_result { operation_results }) ->
List.fold_left
(fun acc (_, r) -> acc >>? fun acc ->
match r with
| Applied (Transaction_result { consumed_gas }
| Origination_result { consumed_gas }) ->
Ok (Z.add consumed_gas acc)
| Applied Reveal_result -> Ok acc
| Applied Delegation_result -> Ok acc
| Skipped -> assert false
| Failed errs -> Alpha_environment.wrap_error (Error errs))
(Ok Z.zero) operation_results
| _ -> Ok Z.zero
let originated_contracts = function
| Sourced_operation_result (Manager_operations_result { operation_results }) ->
List.fold_left
(fun acc (_, r) -> acc >>? fun acc ->
match r with
| Applied (Transaction_result { originated_contracts }
| Origination_result { originated_contracts }) ->
Ok (originated_contracts @ acc)
| Applied Reveal_result -> Ok acc
| Applied Delegation_result -> Ok acc
| Skipped -> assert false
| Failed errs -> Alpha_environment.wrap_error (Error errs))
(Ok []) operation_results
| _ -> Ok []
let transfer (cctxt : #Proto_alpha.full)
block ?branch
~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee ?gas_limit () =
@ -130,18 +433,14 @@ let transfer (cctxt : #Proto_alpha.full)
let signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (_, _, gas) ->
match gas with
| Limited { remaining } ->
let gas = Z.sub max_gas remaining in
predecessor oph bytes (Some signature) >>=? fun result ->
Lwt.return (estimated_gas result) >>=? fun gas ->
if Z.equal gas Z.zero then
cctxt#message "Estimated gas: none" >>= fun () ->
return Z.zero
else
let gas = Z.sub max_gas remaining in
cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
return (Z.add gas (Z.of_int 100))
| Unaccounted -> assert false
end >>=? fun gas_limit ->
Alpha_services.Forge.Manager.transaction
cctxt block
@ -152,12 +451,14 @@ let transfer (cctxt : #Proto_alpha.full)
let signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (contracts, operations, _) ->
cctxt#message "@[<v 2>This sequence of operations was run (including internal ones):@,%a@]"
(Format.pp_print_list pp_internal_operation) operations >>= fun () ->
predecessor oph bytes (Some signature) >>=? fun result ->
cctxt#message
"@[<v 2>This sequence of operations was run:@,%a@]"
pp_operation_result (Data_encoding.Binary.of_bytes_exn Operation.encoding signed_bytes, result) >>= fun () ->
Shell_services.inject_operation
cctxt ~chain_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ;
Lwt.return (originated_contracts result) >>=? fun contracts ->
return (oph, contracts)
let reveal cctxt
@ -185,16 +486,17 @@ let originate (cctxt : #Client_context.full) ?chain_id ~block ?signature bytes =
Block_services.predecessor cctxt block >>=? fun predecessor ->
let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes signature >>=? function
| [ contract ], operations, _ ->
predecessor oph bytes signature >>=? fun result ->
Lwt.return (originated_contracts result) >>=? function
| [ contract ] ->
cctxt#message
"@[<v 2>This sequence of operations was run (including internal ones):@,%a@]"
(Format.pp_print_list pp_internal_operation) operations >>= fun () ->
"@[<v 2>This sequence of operations was run:@,%a@]"
pp_operation_result (Data_encoding.Binary.of_bytes_exn Operation.encoding signed_bytes, result) >>= fun () ->
Shell_services.inject_operation
cctxt ?chain_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ;
return (oph, contract)
| contracts, _, _ ->
| contracts ->
failwith
"The origination introduced %d contracts instead of one."
(List.length contracts)
@ -205,7 +507,7 @@ let operation_submitted_message (cctxt : #Client_context.printer) ?(contracts =
Lwt_list.iter_s
(fun c ->
cctxt#message
"New contract %a originated from a smart contract."
"New contract %a originated."
Contract.pp c)
contracts >>= return
@ -349,17 +651,14 @@ let originate_contract
let signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (_, _, gas) ->
match gas with
| Limited { remaining } ->
let gas = Z.sub max_gas remaining in
predecessor oph bytes (Some signature) >>=? fun result ->
Lwt.return (estimated_gas result) >>=? fun gas ->
if Z.equal gas Z.zero then
cctxt#message "Estimated gas: none" >>= fun () ->
return Z.zero
else
cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
return (Z.add gas (Z.of_int 100))
| Unaccounted -> assert false
end >>=? fun gas_limit ->
Alpha_services.Forge.Manager.origination cctxt block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager

3
src/proto_alpha/lib_client/client_proto_context.mli
View File

@ -59,6 +59,9 @@ val operation_submitted_message :
val pp_internal_operation:
Format.formatter -> internal_operation -> unit
val pp_operation_result :
Format.formatter -> (operation * Apply_operation_result.operation_result) -> unit
val source_to_keys:
#Proto_alpha.full ->
Block_services.block ->

1
src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL
View File

@ -64,6 +64,7 @@
"Baking",
"Amendment",
"Apply_operation_result",
"Apply",
"Services_registration",

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

@ -327,6 +327,8 @@ let () =
(function Multiple_revelation -> Some () | _ -> None)
(fun () -> Multiple_revelation)
open Apply_operation_result
let apply_consensus_operation_content ctxt
pred_block block_priority operation = function
| Endorsements { block ; level ; slots } ->
@ -354,7 +356,7 @@ let apply_consensus_operation_content ctxt
Baking.freeze_endorsement_deposit ctxt delegate >>=? fun ctxt ->
Baking.endorsement_reward ctxt ~block_priority >>=? fun reward ->
Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt ->
return ctxt
return (ctxt, Endorsements_result (delegate, slots))
let apply_amendment_operation_content ctxt delegate = function
| Proposals { period ; proposals } ->
@ -368,57 +370,94 @@ let apply_amendment_operation_content ctxt delegate = function
(Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
Amendment.record_ballot ctxt delegate proposal ballot
let apply_manager_operation_content
ctxt ~payer ~source ~internal = function
| Reveal _ -> return (ctxt, None, Tez.zero, [])
| Transaction { amount ; parameters ; destination } ->
begin
begin
let gas_difference ctxt_before ctxt_after =
match Gas.level ctxt_before, Gas.level ctxt_after with
| Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after
| _ -> Z.zero
let new_contracts ctxt_before ctxt_after =
Contract.originated_from_current_nonce ctxt_before >>=? fun before ->
Contract.originated_from_current_nonce ctxt_after >>=? fun after ->
return (List.filter (fun c -> not (List.exists (Contract.equal c) before)) after)
let cleanup_balance_updates balance_updates =
List.filter
(fun (_, (Credited update | Debited update)) ->
not (Tez.equal update Tez.zero))
balance_updates
let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
let before_operation = ctxt in
Contract.must_exist ctxt source >>=? fun () ->
match operation with
| Reveal _ -> return (ctxt, Reveal_result)
| Transaction { amount ; parameters ; destination } -> begin
let spend =
if internal then
Contract.spend_from_script ctxt source amount
Contract.spend_from_script
else
Contract.spend ctxt source amount
end >>=? fun ctxt ->
Contract.spend in
spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with
| None -> begin
match parameters with
| None ->
return (ctxt, None, Tez.zero, [])
| None -> return ()
| Some arg ->
match Micheline.root arg with
| Prim (_, D_Unit, [], _) ->
return (ctxt, None, Tez.zero, [])
return ()
| _ -> fail (Bad_contract_parameter (destination, None, parameters))
end
end >>=? fun () ->
let result =
Transaction_result
{ operations = [] ;
storage = None ;
balance_updates =
cleanup_balance_updates
[ Contract source, Debited amount ;
Contract destination, Credited amount ] ;
originated_contracts = [] ;
consumed_gas = gas_difference before_operation ctxt ;
storage_fees_increment = Tez.zero } in
return (ctxt, result)
| Some script ->
let call_contract ctxt parameter =
Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
let arg_type = Micheline.strip_locations arg_type in
begin match parameters, Micheline.root arg_type with
| None, Prim (_, T_unit, _, _) ->
return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))))
| Some parameters, _ ->
trace
(Bad_contract_parameter (destination, Some arg_type, Some parameters))
(Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type)) >>=? fun ctxt ->
return (ctxt, parameters)
| None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
end >>=? fun (ctxt, parameter) ->
Script_interpreter.execute
ctxt
~check_operations:(not internal)
~source ~payer ~self:(destination, script) ~amount ~parameter
>>= function
| Ok { ctxt ; storage ; big_map_diff ; operations } ->
>>=? fun { ctxt ; storage ; big_map_diff ; operations } ->
Contract.update_script_storage
ctxt destination storage big_map_diff >>=? fun ctxt ->
Fees.update_script_storage
ctxt ~payer destination >>=? fun (ctxt, fees) ->
return (ctxt, None, fees, operations)
| Error err ->
return (ctxt, Some err, Tez.zero, []) in
Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
let arg_type = Micheline.strip_locations arg_type in
match parameters, Micheline.root arg_type with
| None, Prim (_, T_unit, _, _) ->
call_contract ctxt (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)))
| Some parameters, _ -> begin
Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type) >>= function
| Ok ctxt -> call_contract ctxt parameters
| Error errs ->
let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in
return (ctxt, Some ((err :: errs)), Tez.zero, [])
end
| None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
new_contracts before_operation ctxt >>=? fun originated_contracts ->
let result =
Transaction_result
{ operations ;
storage = Some storage ;
balance_updates =
cleanup_balance_updates
[ Contract payer, Debited fees ;
Contract source, Debited amount ;
Contract destination, Credited amount ;
(* FIXME: this is wrong until we have asynchronous orignations *) ] ;
originated_contracts ;
consumed_gas = gas_difference before_operation ctxt ;
storage_fees_increment = fees } in
return (ctxt, result)
end
| Origination { manager ; delegate ; script ;
spendable ; delegatable ; credit } ->
@ -434,55 +473,70 @@ let apply_manager_operation_content
~manager ~delegate ~balance:credit
?script
~spendable ~delegatable >>=? fun (ctxt, contract) ->
Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
return (ctxt, None, Tez.zero, [])
Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, fees) ->
let result =
Origination_result
{ balance_updates =
cleanup_balance_updates
[ Contract payer, Debited fees ;
Contract source, Debited credit ;
Contract contract, Credited credit ] ;
originated_contracts = [ contract ] ;
consumed_gas = gas_difference before_operation ctxt ;
storage_fees_increment = fees } in
return (ctxt, result)
| Delegation delegate ->
Delegate.set ctxt source delegate >>=? fun ctxt ->
return (ctxt, None, Tez.zero, [])
return (ctxt, Delegation_result)
let apply_internal_manager_operations ctxt ~payer ops =
let rec apply ctxt storage_fees applied worklist =
let rec apply ctxt applied worklist =
match worklist with
| [] -> return (ctxt, None, storage_fees, List.rev applied)
| [] -> Lwt.return (Ok (ctxt, applied))
| { source ; operation ;
signature = _ (* at this point the signature must have been
checked if the operation has been
deserialized from the outside world *) } as op :: rest ->
apply_manager_operation_content ctxt ~source ~payer ~internal:true operation
>>=? fun (ctxt, ignored_error, operation_storage_fees, emitted) ->
Lwt.return Tez.(storage_fees +? operation_storage_fees) >>=? fun storage_fees ->
match ignored_error with
| Some err ->
return (ctxt, Some err, storage_fees, List.rev (op :: applied))
| None ->
apply ctxt storage_fees (op :: applied) (rest @ emitted) in
apply ctxt Tez.zero [] ops
apply_manager_operation_content ctxt ~source ~payer ~internal:true operation >>= function
| Error errors ->
let result = Internal op, Failed errors in
let skipped = List.rev_map (fun op -> Internal op, Skipped) rest in
Lwt.return (Error (skipped @ (result :: applied)))
| Ok (ctxt, (Transaction_result { operations = emitted ; _ } as result)) ->
apply ctxt ((Internal op, Applied result) :: applied) (rest @ emitted)
| Ok (ctxt, result) ->
apply ctxt ((Internal op, Applied result) :: applied) rest in
apply ctxt [] ops
let apply_manager_operations ctxt source ops =
let rec apply ctxt storage_fees applied ops =
let rec apply ctxt applied ops =
match ops with
| [] -> return (ctxt, None, storage_fees, List.rev applied)
| [] -> Lwt.return (Ok (ctxt, List.rev applied))
| operation :: rest ->
Contract.must_exist ctxt source >>=? fun () ->
apply_manager_operation_content ctxt ~source ~payer:source ~internal:false operation
>>=? fun (ctxt, ignored_error, operation_storage_fees, emitted) ->
Lwt.return Tez.(storage_fees +? operation_storage_fees) >>=? fun storage_fees ->
let op = { source ; operation ; signature = None } in
match ignored_error with
| Some _ -> return (ctxt, ignored_error, storage_fees, List.rev (op :: applied))
| None ->
>>= function
| Error errors ->
let result = External, Failed errors in
let skipped = List.rev_map (fun _ -> External, Skipped) rest in
Lwt.return (Error (List.rev (skipped @ (result :: applied))))
| Ok (ctxt, result) ->
let emitted =
match result with
| Transaction_result { operations = emitted ; _ } -> emitted
| _ -> [] in
apply_internal_manager_operations ctxt ~payer:source emitted
>>=? fun (ctxt, ignored_error, internal_storage_fees, internal_applied) ->
let applied = List.rev internal_applied @ (op :: applied) in
Lwt.return Tez.(storage_fees +? internal_storage_fees) >>=? fun storage_fees ->
match ignored_error with
| Some _ -> return (ctxt, ignored_error, storage_fees, List.rev applied)
| None -> apply ctxt storage_fees applied rest in
apply ctxt Tez.zero [] ops
>>= function
| Error (results) ->
let result = (External, Applied result) in
let skipped = List.map (fun _ -> External, Skipped) rest in
Lwt.return (Error (List.rev (skipped @ results @ (result :: applied))))
| Ok (ctxt, results) ->
let result = (External, Applied result) in
let applied = results @ (result :: applied) in
apply ctxt applied rest in
apply ctxt [] ops
let apply_sourced_operation
ctxt pred_block block_prio
operation ops =
let apply_sourced_operation ctxt pred_block block_prio operation ops =
match ops with
| Manager_operations { source ; fee ; counter ; operations ; gas_limit } ->
let revealed_public_keys =
@ -506,32 +560,40 @@ let apply_sourced_operation
Contract.spend ctxt source fee >>=? fun ctxt ->
add_fees ctxt fee >>=? fun ctxt ->
Lwt.return (Gas.set_limit ctxt gas_limit) >>=? fun ctxt ->
apply_manager_operations ctxt source operations
>>=? fun (ctxt, ignored_error, storage_fees, applied) ->
return (ctxt, ignored_error, storage_fees, applied)
apply_manager_operations ctxt source operations >>= begin function
| Ok (ctxt, operation_results) -> return (ctxt, operation_results)
| Error operation_results -> return (ctxt (* backtracked *), operation_results)
end >>=? fun (ctxt, operation_results) ->
return (ctxt,
Manager_operations_result
{ balance_updates =
cleanup_balance_updates
[ Contract source, Debited fee ;
(* FIXME: add credit to the baker *) ] ;
operation_results })
| Consensus_operation content ->
apply_consensus_operation_content ctxt
pred_block block_prio operation content >>=? fun ctxt ->
return (ctxt, None, Tez.zero, [])
pred_block block_prio operation content >>=? fun (ctxt, result) ->
return (ctxt, Consensus_operation_result result)
| Amendment_operation { source ; operation = content } ->
Roll.delegate_pubkey ctxt source >>=? fun delegate ->
Operation.check_signature delegate operation >>=? fun () ->
(* TODO, see how to extract the public key hash after this operation to
pass it to apply_delegate_operation_content *)
apply_amendment_operation_content ctxt source content >>=? fun ctxt ->
return (ctxt, None, Tez.zero, [])
return (ctxt, Amendment_operation_result)
| Dictator_operation (Activate hash) ->
let dictator_pubkey = Constants.dictator_pubkey ctxt in
Operation.check_signature dictator_pubkey operation >>=? fun () ->
activate ctxt hash >>= fun ctxt ->
return (ctxt, None, Tez.zero, [])
return (ctxt, Dictator_operation_result)
| Dictator_operation (Activate_testchain hash) ->
let dictator_pubkey = Constants.dictator_pubkey ctxt in
Operation.check_signature dictator_pubkey operation >>=? fun () ->
let expiration = (* in two days maximum... *)
Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in
fork_test_chain ctxt hash expiration >>= fun ctxt ->
return (ctxt, None, Tez.zero, [])
return (ctxt, Dictator_operation_result)
let apply_anonymous_operation ctxt _delegate kind =
match kind with
@ -541,7 +603,7 @@ let apply_anonymous_operation ctxt _delegate kind =
let seed_nonce_revelation_tip =
Constants.seed_nonce_revelation_tip ctxt in
add_rewards ctxt seed_nonce_revelation_tip >>=? fun ctxt ->
return ctxt
return (ctxt, Seed_nonce_revelation_result [(* FIXME *)])
| Double_endorsement_evidence { op1 ; op2 } -> begin
match op1.contents, op2.contents with
| Sourced_operations (Consensus_operation (Endorsements e1)),
@ -580,7 +642,7 @@ let apply_anonymous_operation ctxt _delegate kind =
| Ok v -> v
| Error _ -> Tez.zero in
add_rewards ctxt reward >>=? fun ctxt ->
return ctxt
return (ctxt, Double_endorsement_evidence_result [(* FIXME *)])
| _, _ -> fail Invalid_double_endorsement_evidence
end
| Double_baking_evidence { bh1 ; bh2 } ->
@ -619,7 +681,7 @@ let apply_anonymous_operation ctxt _delegate kind =
| Ok v -> v
| Error _ -> Tez.zero in
add_rewards ctxt reward >>=? fun ctxt ->
return ctxt
return (ctxt, Double_baking_evidence_result [(* FIXME *)])
| Activation { id = pkh ; secret } ->
let h_pkh = Unclaimed_public_key_hash.of_ed25519_pkh pkh in
Commitment.get_opt ctxt h_pkh >>=? function
@ -631,17 +693,7 @@ let apply_anonymous_operation ctxt _delegate kind =
Wrong_activation_secret >>=? fun () ->
Commitment.delete ctxt h_pkh >>=? fun ctxt ->
Contract.(credit ctxt (implicit_contract (Signature.Ed25519 pkh)) amount) >>=? fun ctxt ->
return ctxt
type operation_result =
{ ctxt : context ;
gas : Gas.t ;
contracts : Contract.t list ;
ignored_error : error list option ;
internal_operations : internal_operation list ;
fees : Tez.t ;
rewards : Tez.t ;
storage_fees : Tez.t }
return (ctxt, Activation_result [(* FIXME *)])
let apply_operation
ctxt delegate pred_block block_prio hash operation =
@ -649,24 +701,20 @@ let apply_operation
begin match operation.contents with
| Anonymous_operations ops ->
fold_left_s
(fun ctxt op ->
apply_anonymous_operation ctxt delegate op)
ctxt ops
>>=? fun ctxt ->
return (ctxt, None, Tez.zero, [])
| Sourced_operations op ->
apply_sourced_operation
ctxt pred_block block_prio
operation op
end >>=? fun (ctxt, ignored_error, storage_fees, internal_operations) ->
let gas = Gas.level ctxt in
(fun (ctxt, acc) op ->
apply_anonymous_operation ctxt delegate op >>=? fun (ctxt, result) ->
return (ctxt, result :: acc))
(ctxt, []) ops
>>=? fun (ctxt, results) ->
return (ctxt, Anonymous_operations_result (List.rev results))
| Sourced_operations ops ->
apply_sourced_operation ctxt pred_block block_prio operation ops
>>=? fun (ctxt, result) ->
return (ctxt, Sourced_operation_result result)
end >>=? fun (ctxt, result) ->
let ctxt = Gas.set_unlimited ctxt in
Contract.originated_from_current_nonce ctxt >>=? fun contracts ->
let ctxt = Contract.unset_origination_nonce ctxt in
return { ctxt ; gas ; ignored_error ; storage_fees ;
internal_operations ; contracts ;
fees = Alpha_context.get_fees ctxt ;
rewards = Alpha_context.get_rewards ctxt }
return (ctxt, result)
let may_snapshot_roll ctxt =
let level = Alpha_context.Level.current ctxt in

277
src/proto_alpha/lib_protocol/src/apply_operation_result.ml Normal file
View File

@ -0,0 +1,277 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Alpha_context
open Data_encoding
type balance =
| Contract of Contract.t
| Rewards of Signature.Public_key_hash.t * Cycle.t
| Fees of Signature.Public_key_hash.t * Cycle.t
| Deposits of Signature.Public_key_hash.t * Cycle.t
let balance_encoding =
union
[ case Json_only
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract.encoding))
(function Contract c -> Some ((), c) | _ -> None )
(fun ((), c) -> (Contract c)) ;
case Json_only
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "rewards"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "level" Cycle.encoding))
(function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Rewards (d, l)) ;
case Json_only
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "fees"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "level" Cycle.encoding))
(function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Fees (d, l)) ;
case Json_only
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "deposits"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "level" Cycle.encoding))
(function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Deposits (d, l)) ]
type balance_update =
| Debited of Tez.t
| Credited of Tez.t
let balance_update_encoding =
union
[ case Json_only
(obj1 (req "credited" Tez.encoding))
(function Credited v -> Some v | Debited _ -> None)
(fun v -> Credited v) ;
case Json_only
(obj1 (req "debited" Tez.encoding))
(function Debited v -> Some v | Credited _ -> None)
(fun v -> Debited v) ]
type balance_updates = (balance * balance_update) list
let balance_updates_encoding =
list (merge_objs balance_encoding balance_update_encoding)
type anonymous_operation_result =
| Seed_nonce_revelation_result of balance_updates
| Double_endorsement_evidence_result of balance_updates
| Double_baking_evidence_result of balance_updates
| Activation_result of balance_updates
let anonymous_operation_result_encoding =
union
[ case Json_only
(obj2
(req "kind" (constant "revelation"))
(req "balance_updates" balance_updates_encoding))
(function Seed_nonce_revelation_result bus -> Some ((), bus) | _ -> None)
(fun ((), bus) -> Seed_nonce_revelation_result bus) ;
case Json_only
(obj2
(req "kind" (constant "double_endorsement"))
(req "balance_updates" balance_updates_encoding))
(function Double_endorsement_evidence_result bus -> Some ((), bus) | _ -> None)
(fun ((), bus) -> Double_endorsement_evidence_result bus) ;
case Json_only
(obj2
(req "kind" (constant "double_baking"))
(req "balance_updates" balance_updates_encoding))
(function Double_baking_evidence_result bus -> Some ((), bus) | _ -> None)
(fun ((), bus) -> Double_baking_evidence_result bus) ;
case Json_only
(obj2
(req "kind" (constant "activation"))
(req "balance_updates" balance_updates_encoding))
(function Activation_result bus -> Some ((), bus) | _ -> None)
(fun ((), bus) -> Activation_result bus) ]
type successful_manager_operation_result =
| Reveal_result
| Transaction_result of
{ operations : internal_operation list ;
storage : Script.expr option ;
balance_updates : balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_fees_increment : Tez.t }
| Origination_result of
{ balance_updates : balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_fees_increment : Tez.t }
| Delegation_result
type manager_operation_kind =
| External
| Internal of internal_operation
let manager_operation_kind_encoding =
union
[ case Json_only (constant "external")
(function External -> Some () | _ -> None)
(fun () -> External) ;
case Json_only Operation.internal_operation_encoding
(function Internal op -> Some op | _ -> None)
(fun op -> Internal op) ]
type manager_operation_result =
| Applied of successful_manager_operation_result
| Failed of error list
| Skipped
let manager_operation_result_encoding =
union
[ case Json_only
(obj2
(req "status" (constant "applied"))
(req "operation_kind" (constant "reveal")))
(function Applied Reveal_result -> Some ((),()) | _ -> None)
(fun ((),()) -> Applied Reveal_result) ;
case Json_only
(obj8
(req "status" (constant "applied"))
(req "operation_kind" (constant "transaction"))
(dft "emitted" (list Operation.internal_operation_encoding) [])
(opt "storage" Script.expr_encoding)
(dft "balance_updates" balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_fees_increment" Tez.encoding Tez.zero))
(function
| Applied (Transaction_result
{ operations ; storage ; balance_updates ;
originated_contracts ; consumed_gas ;
storage_fees_increment }) ->
Some ((), (), operations, storage, balance_updates,
originated_contracts, consumed_gas,
storage_fees_increment)
| _ -> None)
(fun ((), (), operations, storage, balance_updates,
originated_contracts, consumed_gas,
storage_fees_increment) ->
Applied (Transaction_result
{ operations ; storage ; balance_updates ;
originated_contracts ; consumed_gas ;
storage_fees_increment })) ;
case Json_only
(obj6
(req "status" (constant "applied"))
(req "operation_kind" (constant "origination"))
(dft "balance_updates" balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_fees_increment" Tez.encoding Tez.zero))
(function
| Applied (Origination_result
{ balance_updates ;
originated_contracts ; consumed_gas ;
storage_fees_increment }) ->
Some ((), (), balance_updates,
originated_contracts, consumed_gas,
storage_fees_increment)
| _ -> None)
(fun ((), (), balance_updates,
originated_contracts, consumed_gas,
storage_fees_increment) ->
Applied (Origination_result
{ balance_updates ;
originated_contracts ; consumed_gas ;
storage_fees_increment })) ;
case Json_only
(obj2
(req "status" (constant "applied"))
(req "operation_kind" (constant "delegation")))
(function Applied Delegation_result -> Some ((),()) | _ -> None)
(fun ((),()) -> Applied Delegation_result) ;
case Json_only
(obj2
(req "status" (constant "failed"))
(req "errors" (list Error_monad.error_encoding)))
(function Failed errs -> Some ((), errs) | _ -> None)
(fun ((), errs) -> Failed errs) ;
case Json_only
(obj1 (req "status" (constant "skipped")))
(function Skipped -> Some () | _ -> None)
(fun () -> Skipped) ]
type consensus_operation_result =
| Endorsements_result of Signature.Public_key_hash.t * int list
type sourced_operation_result =
| Consensus_operation_result of consensus_operation_result
| Amendment_operation_result
| Manager_operations_result of
{ balance_updates : balance_updates ;
operation_results : (manager_operation_kind * manager_operation_result) list }
| Dictator_operation_result
type operation_result =
| Anonymous_operations_result of anonymous_operation_result list
| Sourced_operation_result of sourced_operation_result
let encoding =
union
[ case Json_only
(obj2
(req "kind" (constant "anonymous"))
(req "results" (list anonymous_operation_result_encoding)))
(function Anonymous_operations_result rs -> Some ((), rs) | _ -> None)
(fun ((), rs) -> Anonymous_operations_result rs) ;
case Json_only
(obj3
(req "kind" (constant "endorsements"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "slots" (list uint8)))
(function
| Sourced_operation_result
(Consensus_operation_result
(Endorsements_result (d, s))) -> Some ((), d, s)
| _ -> None)
(fun ((), d, s) ->
Sourced_operation_result
(Consensus_operation_result
(Endorsements_result (d, s)))) ;
case Json_only
(obj1
(req "kind" (constant "amendment")))
(function Sourced_operation_result Amendment_operation_result -> Some () | _ -> None)
(fun () -> Sourced_operation_result Amendment_operation_result) ;
case Json_only
(obj1
(req "kind" (constant "dictator")))
(function Sourced_operation_result Dictator_operation_result -> Some () | _ -> None)
(fun () -> Sourced_operation_result Dictator_operation_result) ;
case Json_only
(obj3
(req "kind" (constant "manager"))
(req "balance_updates" balance_updates_encoding)
(req "operation_results"
(list (merge_objs
(obj1 (req "operation" manager_operation_kind_encoding))
manager_operation_result_encoding))))
(function
| Sourced_operation_result
(Manager_operations_result
{ balance_updates = bus ; operation_results = rs }) ->
Some ((), bus, rs) | _ -> None)
(fun ((), bus, rs) ->
Sourced_operation_result
(Manager_operations_result
{ balance_updates = bus ; operation_results = rs })) ]

95
src/proto_alpha/lib_protocol/src/apply_operation_result.mli Normal file
View File

@ -0,0 +1,95 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Result of applying an operation, can be used for experimenting
with protocol updates, by clients to print out a summary of the
operation at pre-injection simulation and at confirmation time,
and by block explorers. *)
open Alpha_context
(** Places where tezzies can be found in the ledger's state. *)
type balance =
| Contract of Contract.t
| Rewards of Signature.Public_key_hash.t * Cycle.t
| Fees of Signature.Public_key_hash.t * Cycle.t
| Deposits of Signature.Public_key_hash.t * Cycle.t
(** A credit or debit of tezzies to a balance. *)
type balance_update =
| Debited of Tez.t
| Credited of Tez.t
(** A list of balance updates. Duplicates may happen. *)
type balance_updates = (balance * balance_update) list
(** Result of applying a {!proto_operation}. Follows the same structure. *)
type operation_result =
| Anonymous_operations_result of anonymous_operation_result list
| Sourced_operation_result of sourced_operation_result
(** Result of applying an {!anonymous_operation}. Follows the same structure. *)
and anonymous_operation_result =
| Seed_nonce_revelation_result of balance_updates
| Double_endorsement_evidence_result of balance_updates
| Double_baking_evidence_result of balance_updates
| Activation_result of balance_updates
(** Result of applying a {!sourced_operation}.
Follows the same structure, except for [Manager_operations_result]
which includes the results of internal operations, in execution order. *)
and sourced_operation_result =
| Consensus_operation_result of consensus_operation_result
| Amendment_operation_result
| Manager_operations_result of
{ balance_updates : balance_updates ;
operation_results : (manager_operation_kind * manager_operation_result) list }
| Dictator_operation_result
(** Result of applying a {!consensus_operation}. Follows the same structure. *)
and consensus_operation_result =
| Endorsements_result of Signature.Public_key_hash.t * int list
(** An operation descriptor in the queue of emitted manager
operations. [External] points to a {!manager_operation_content} in
the toplevel {!manager_operation}. The operations are executed in a
queue, so the n-th [External] corresponds to the [n-th]
{!manager_operation_content}. [Internal] points to an operation
emitted by a contract, whose contents is given verbatim. *)
and manager_operation_kind =
| External
| Internal of internal_operation
(** The result of an operation in the queue. [Skipped] ones should
always be at the tail, and after a single [Failed]. *)
and manager_operation_result =
| Applied of successful_manager_operation_result
| Failed of error list
| Skipped
(** Result of applying a {!manager_operation_content}, either internal
or external. *)
and successful_manager_operation_result =
| Reveal_result
| Transaction_result of
{ operations : internal_operation list ;
storage : Script.expr option ;
balance_updates : balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_fees_increment : Tez.t }
| Origination_result of
{ balance_updates : balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_fees_increment : Tez.t }
| Delegation_result
(** Serializer for {!proto_operation_result}. *)
val encoding : operation_result Data_encoding.t

3
src/proto_alpha/lib_protocol/src/fees.ml
View File

@ -29,7 +29,8 @@ let origination_burn c ~payer contract =
Contract.fees c contract >>=? fun fees ->
trace Cannot_pay_storage_fee
(Contract.spend_from_script c payer fees >>=? fun c ->
Contract.add_to_paid_fees c contract fees)
Contract.add_to_paid_fees c contract fees) >>=? fun c ->
return (c, fees)
let update_script_storage c ~payer contract =
Contract.paid_fees c contract >>=? fun paid_fees ->

2
src/proto_alpha/lib_protocol/src/fees.mli
View File

@ -13,7 +13,7 @@ type error += Cannot_pay_storage_fee
val origination_burn:
Alpha_context.t -> payer:Contract.t ->
Contract.t -> Alpha_context.t tzresult Lwt.t
Contract.t -> (Alpha_context.t * Tez.t) tzresult Lwt.t
val update_script_storage:
Alpha_context.t -> payer:Contract.t ->

10
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -51,10 +51,7 @@ module S = struct
(req "operation_hash" Operation_hash.encoding)
(req "forged_operation" bytes)
(opt "signature" Signature.encoding))
~output: (obj3
(req "contracts" (list Contract.encoding))
(req "internal_operations" (list Operation.internal_operation_encoding))
(req "remaining_gas" Gas.encoding))
~output: Apply_operation_result.encoding
RPC_path.(custom_root / "apply_operation")
let trace_code =
@ -150,10 +147,7 @@ module I = struct
let block_prio = 0 in
Apply.apply_operation
ctxt (Some baker_pkh) pred_block block_prio hash operation
>>=? function
| { ignored_error = Some script_err ; _ } -> Lwt.return (Error script_err)
| { gas ; contracts ; internal_operations ; _ } ->
Lwt.return (Ok (contracts, internal_operations, gas))
>>=? fun (_, result) -> return result
end

2
src/proto_alpha/lib_protocol/src/helpers_services.mli
View File

@ -19,7 +19,7 @@ val minimal_time:
val apply_operation:
'a #RPC_context.simple ->
'a -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Signature.t option ->
(Contract.t list * internal_operation list * Gas.t) shell_tzresult Lwt.t
Apply_operation_result.operation_result shell_tzresult Lwt.t
val run_code:
'a #RPC_context.simple ->

2
src/proto_alpha/lib_protocol/src/main.ml
View File

@ -116,7 +116,7 @@ let apply_operation ({ mode ; ctxt ; op_count ; _ } as data) operation =
Some baker in
Apply.apply_operation ctxt baker pred_block block_prio
(Alpha_context.Operation.hash operation) operation
>>=? fun { Apply.ctxt ; _ } ->
>>=? fun (ctxt, _) ->
let op_count = op_count + 1 in
return { data with ctxt ; op_count }

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

@ -166,7 +166,7 @@ let rec interp
~script:({ code ; storage }, None (* TODO: initialize a big map from a map *))
~spendable ~delegatable
>>=? fun (ctxt, contract) ->
Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, _) ->
logged_return descr (Item ((param_type, contract), rest), ctxt) in
let logged_return :
a stack * context ->
@ -676,7 +676,7 @@ let rec interp
Contract.originate ctxt
~manager ~delegate ~balance
?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract) ->
Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, _) ->
logged_return (Item ((Unit_t, contract), rest), ctxt)
| Implicit_account, Item (key, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->

27
src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml
View File

@ -8,6 +8,29 @@
(**************************************************************************)
open Proto_alpha.Error_monad
open Proto_alpha.Apply_operation_result
let extract_result = function
| Sourced_operation_result (Manager_operations_result { operation_results }) ->
List.fold_left
(fun (acc, err) (_, r) ->
match r with
| Applied (Transaction_result { originated_contracts }
| Origination_result { originated_contracts }) ->
(originated_contracts @ acc, err)
| Applied Reveal_result
| Applied Delegation_result
| Skipped -> (acc, err)
| Failed errs -> (acc, Some errs))
([], None) operation_results
| _ -> ([], None)
let bind_result (tc, result) =
match extract_result result with
| _, Some err ->
Lwt.return (Error err)
| contracts, None ->
return (contracts, tc)
let operation
~tc ?(baker: Helpers_account.t option) ?(src: Helpers_account.t option)
@ -20,8 +43,8 @@ let operation
pred_block_hash
0
hash
operation >>=? fun { ctxt = tc ; contracts ; ignored_error } ->
return ((contracts, ignored_error), tc)
operation
>>=? bind_result
let transaction ~tc ?(fee = 0) ?baker

18
src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli
View File

@ -15,44 +15,44 @@ open Alpha_context
val operation :
tc:context -> ?baker:Helpers_account.t -> ?src:Helpers_account.t ->
Block_hash.t -> Tezos_base.Operation.shell_header -> proto_operation ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val transaction :
tc:context -> ?fee:int -> ?baker:Helpers_account.t -> Block_hash.t ->
Tezos_base.Operation.shell_header -> Helpers_account.t -> Helpers_account.t -> int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val transaction_pred :
?tc:t -> pred:Helpers_block.result -> ?baker:Helpers_account.t ->
Helpers_account.t * Helpers_account.t * int * int option ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val script_origination :
tc:context -> Block_hash.t -> Tezos_base.Operation.shell_header ->
Script.t option -> Helpers_account.t -> int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val origination :
tc:context -> ?baker:Helpers_account.t -> ?spendable:bool -> ?fee:int ->
?delegatable:bool -> Block_hash.t -> Tezos_base.Operation.shell_header ->
Helpers_account.t -> int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val script_origination_pred :
?tc:t -> pred:Helpers_block.result -> Script.t * Helpers_account.t * int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val origination_pred :
?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
Helpers_account.t * int * bool * bool * int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val delegation :
tc:context -> ?baker:Helpers_account.t -> ?fee:int -> Block_hash.t ->
Tezos_base.Operation.shell_header -> Helpers_account.t -> public_key_hash ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t
val delegation_pred :
?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
Helpers_account.t * public_key_hash * int ->
((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
(Contract.contract list * context) proto_tzresult Lwt.t

2
src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml
View File

@ -18,7 +18,7 @@ let execute_code_pred
let op = List.nth Helpers_account.bootstrap_accounts 0 in
let tc = Option.unopt ~default:pred.tezos_context tc in
Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount)
>>=? fun ((dst, _), tc) ->
>>=? fun (dst, tc) ->
let dst = List.hd dst in
let ctxt = Helpers_cast.ctxt_of_tc tc in
let gas = Proto_alpha.Alpha_context.Constants.hard_gas_limit_per_operation tc in

12
src/proto_alpha/lib_protocol/test/test_big_maps.ml
View File

@ -73,11 +73,7 @@ let main () =
let src = List.hd Helpers.Account.bootstrap_accounts in
Lwt.return (parse_script code storage) >>=? fun script ->
Helpers.Apply.script_origination_pred
~tc ~pred (script , src, 100_00) >>=?? fun ((contracts, errs), tc) ->
begin match errs with
| None | Some [] -> Proto_alpha.Error_monad.return ()
| Some (err :: _) -> Proto_alpha.Error_monad.fail err
end >>=?? fun () ->
~tc ~pred (script , src, 100_00) >>=?? fun (contracts, tc) ->
begin match contracts with
| [ contract ] -> return contract
| _ -> failwith "more than one contract"
@ -103,11 +99,7 @@ let main () =
Helpers.Apply.operation ~tc
~src pred.Helpers_block.hash
(Helpers_block.get_op_header_res pred)
op >>=?? fun ((_, errs), tc) ->
begin match errs with
| None | Some [] -> Proto_alpha.Error_monad.return ()
| Some (err :: _) -> Proto_alpha.Error_monad.fail err
end >>=?? fun () ->
op >>=?? fun (_, tc) ->
expect_big_map tc result >>=?? fun () ->
debug "big map after call %s is ok" input ;
return tc in

10
src/proto_alpha/lib_protocol/test/test_dsl.ml
View File

@ -52,7 +52,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
transfer
account_a
account_unknown_foo
10000 >>= Assert.ok_contract >>=? fun (_, tc) ->
10000 >>= Assert.ok >>=? fun (_, tc) ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
debug "Reception" ;
@ -62,7 +62,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
account_a
account_b
1000
>>=? fun ((contracts, _), _) ->
>>=? fun (contracts, _) ->
Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
debug "No contracts originated" ;
@ -71,7 +71,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
account_a
account_b
1000
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) ->
>>= Assert.ok ~msg: __LOC__ >>=? fun (_,tc) ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, 998990) >>=? fun () ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () ->
debug "Transfer balances" ;
@ -90,7 +90,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
~spendable: false
account_a
1000
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) ->
>>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, tc) ->
Assert.equal_int (List.length contracts) 1 ;
let non_spendable = List.hd contracts in
let account = {account_a with contract = non_spendable} in
@ -105,7 +105,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
~fee: 100
account_a
1000
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) ->
>>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, spendable_tc) ->
Assert.equal_int (List.length contracts) 1 ;
let contract_spendable = List.hd contracts in
let account_spendable = {account_a with contract = contract_spendable} in

28
src/proto_alpha/lib_protocol/test/test_michelson.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Proto_alpha
open Alpha_context
let name = "Isolate Michelson"
module Logger = Logging.Make(struct let name = name end)
@ -44,6 +43,21 @@ let program param st code =
let quote s = "\"" ^ s ^ "\""
open Apply_operation_result
let extract_result rs =
List.fold_left
(fun (acc, err) (_, r) ->
match r with
| Applied (Transaction_result { originated_contracts }
| Origination_result { originated_contracts }) ->
(originated_contracts @ acc, err)
| Applied Reveal_result
| Applied Delegation_result
| Skipped -> (acc, err)
| Failed errs -> (acc, errs))
([], []) rs
let parse_execute sb ?tc code_str param_str storage_str =
let param = parse_param param_str in
let script = parse_script code_str storage_str in
@ -51,17 +65,17 @@ let parse_execute sb ?tc code_str param_str storage_str =
>>=?? fun (dst, { ctxt = tc ; operations = ops ; big_map_diff = bgm }) ->
let payer =
(List.hd Account.bootstrap_accounts).contract in
Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>=?? fun (tc, err, _, ops) ->
Contract.originated_from_current_nonce tc >>=?? fun contracts ->
match err with
| None ->
Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>= function
| Error result ->
let _, err = extract_result result in
Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err)))
| Ok (tc, _) ->
Proto_alpha.Alpha_context.Contract.originated_from_current_nonce tc >>=?? fun contracts ->
let tc = Proto_alpha.Alpha_context.Gas.set_unlimited tc in
Proto_alpha.Alpha_context.Contract.get_storage tc dst >>=?? begin function
| (_, None) -> assert false
| (tc, Some st) -> return (st, ops, tc, contracts, bgm)
end
| Some err ->
Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err)))
let test ctxt ?tc (file_name: string) (storage: string) (input: string) =
let full_path = contract_path // file_name ^ ".tz" in

4
src/proto_alpha/lib_protocol/test/test_origination.ml
View File

@ -56,14 +56,14 @@ let test_delegation () =
(* Delegatable should change delegate *)
originate root ~delegatable: true account_a 200
>>=? fun ((contracts, _errs), tc) ->
>>=? fun (contracts, tc) ->
let contract = List.hd contracts in
let account_ac = {account_a with contract} in
delegate root ~tc account_ac account_b.hpub >>= Assert.ok ~msg: __LOC__ >>= fun _ ->
(* Not-Delegatable should not change delegate *)
originate root ~delegatable: false account_a 200
>>=? fun ((contracts, _errs), tc) ->
>>=? fun (contracts, tc) ->
let contract = List.hd contracts in
let account_a = {account_a with contract} in
delegate root ~tc account_a account_b.hpub >>= Assert.wrap >>= fun res ->

12
src/proto_alpha/lib_protocol/test/test_transaction.ml
View File

@ -48,23 +48,23 @@ let test_basic (): unit tzresult Lwt.t =
(* Send 10 tz to unknown account. *)
transfer (account_a, account_unknown_foo, 10000) >>=
Assert.ok_contract >>=? fun (_, tc) ->
Assert.ok >>=? fun (_, tc) ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
debug "Reception" ;
(* Unknown account transfers back tz. *)
transfer ~tc (account_unknown_foo, account_a, 9990) >>=
Assert.ok_contract >>=? fun _ ->
Assert.ok >>=? fun _ ->
debug "Transfer back" ;
(* Check that a basic transfer originates no contracts. *)
transfer (account_a, account_b, 1000) >>=? fun ((contracts, _), _) ->
transfer (account_a, account_b, 1000) >>=? fun (contracts, _) ->
Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
debug "No contracts originated" ;
(* Check sender/receiver balance post transaction *)
transfer (account_a, account_b, 1000) >>=
Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) ->
Assert.ok ~msg: __LOC__ >>=? fun (_,tc) ->
Proto_alpha.Alpha_context.Contract.get_balance tc account_a.contract >>=? fun _balance ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, init_amount * 100 - 1000 - 10) >>=? fun () ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () ->
@ -78,7 +78,7 @@ let test_basic (): unit tzresult Lwt.t =
(* Check non-spendability of a non-spendable contract *)
(* TODO: Unspecified economic error: should be more specific. *)
originate (account_a, 1000, false, true, 0)
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) ->
>>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, tc) ->
Assert.equal_int (List.length contracts) 1 ;
let non_spendable = List.hd contracts in
let account = {account_a with contract = non_spendable} in
@ -90,7 +90,7 @@ let test_basic (): unit tzresult Lwt.t =
(* Check spendability of a spendable contract *)
originate (account_a, 1000, true, true, 100)
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) ->
>>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, spendable_tc) ->
Assert.equal_int (List.length contracts) 1 ;
let contract_spendable = List.hd contracts in
let account_spendable = {account_a with contract = contract_spendable} in