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

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

@ -12,6 +12,7 @@ open Alpha_context
open Tezos_micheline open Tezos_micheline
open Client_proto_contracts open Client_proto_contracts
open Client_keys open Client_keys
open Apply_operation_result
let get_balance (rpc : #Proto_alpha.rpc_context) block contract = let get_balance (rpc : #Proto_alpha.rpc_context) block contract =
Alpha_services.Contract.balance rpc block contract Alpha_services.Contract.balance rpc block contract
@ -36,15 +37,17 @@ let parse_expression arg =
(Micheline_parser.no_parsing_error (Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression arg)) (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>" ; Format.fprintf ppf "@[<v 0>" ;
begin match operation with begin match operation with
| Alpha_context.Transaction { destination ; amount ; parameters } -> | Alpha_context.Transaction { destination ; amount ; parameters } ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>Transaction:@,\ "@[<v 2>%s:@,\
Of: %a@,\ Amount: %s%a@,\
From: %a@,\ From: %a@,\
To: %a" To: %a"
(if internal then "Internal transaction" else "Transaction")
Client_proto_args.tez_sym
Tez.pp amount Tez.pp amount
Contract.pp source Contract.pp source
Contract.pp destination ; Contract.pp destination ;
@ -55,21 +58,24 @@ let pp_internal_operation ppf { source ; operation } =
"@,Parameter: @[<v 0>%a@]" "@,Parameter: @[<v 0>%a@]"
Michelson_v1_printer.print_expr expr Michelson_v1_printer.print_expr expr
end ; end ;
pp_result ppf result ;
Format.fprintf ppf "@]" ; Format.fprintf ppf "@]" ;
| Origination { manager ; delegate ; credit ; spendable ; delegatable ; script } -> | Origination { manager ; delegate ; credit ; spendable ; delegatable ; script } ->
Format.fprintf ppf "@[<v 2>Origination:@,\ Format.fprintf ppf "@[<v 2>%s:@,\
From: %a@,\ From: %a@,\
For: %a@,\ For: %a@,\
Credit: %a" Credit: %s%a"
(if internal then "Internal origination" else "Origination")
Contract.pp source Contract.pp source
Signature.Public_key_hash.pp manager Signature.Public_key_hash.pp manager
Client_proto_args.tez_sym
Tez.pp credit ; Tez.pp credit ;
begin match script with begin match script with
| None -> Format.fprintf ppf "@,No script (accepts all transactions)" | None -> Format.fprintf ppf "@,No script (accepts all transactions)"
| Some { code ; storage } -> | Some { code ; storage } ->
Format.fprintf ppf Format.fprintf ppf
"@,@[<v 2>Script:@,%a\ "@,@[<hv 2>Script:@ %a\
@,@[<v 2>Initial storage:@,%a@]" @,@[<hv 2>Initial storage:@ %a@]"
Michelson_v1_printer.print_expr code Michelson_v1_printer.print_expr code
Michelson_v1_printer.print_expr storage Michelson_v1_printer.print_expr storage
end ; end ;
@ -79,30 +85,327 @@ let pp_internal_operation ppf { source ; operation } =
end ; end ;
if spendable then Format.fprintf ppf "@,Spendable by its manager" ; if spendable then Format.fprintf ppf "@,Spendable by its manager" ;
if delegatable then Format.fprintf ppf "@,Delegate can be changed later" ; if delegatable then Format.fprintf ppf "@,Delegate can be changed later" ;
pp_result ppf result ;
Format.fprintf ppf "@]" ; Format.fprintf ppf "@]" ;
| Reveal key -> | Reveal key ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>Revelation of manager public key:@,\ "@[<v 2>%s of manager public key:@,\
Contract: %a@,\ Contract: %a@,\
Key: %a@]" Key: %a%a@]"
(if internal then "Internal revelation" else "Revelation")
Contract.pp source Contract.pp source
Signature.Public_key.pp key Signature.Public_key.pp key
pp_result result
| Delegation None -> | Delegation None ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>Delegation:@,\ "@[<v 2>%s:@,\
Contract: %a@,\ Contract: %a@,\
To: nobody@]" To: nobody%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp source Contract.pp source
pp_result result
| Delegation (Some delegate) -> | Delegation (Some delegate) ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>Delegation:@,\ "@[<v 2>%s:@,\
Contract: %a@,\ Contract: %a@,\
To: %a@]" To: %a%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp source Contract.pp source
Signature.Public_key_hash.pp delegate Signature.Public_key_hash.pp delegate
pp_result result
end ; end ;
Format.fprintf ppf "@]" 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) let transfer (cctxt : #Proto_alpha.full)
block ?branch block ?branch
~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee ?gas_limit () = ~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 signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (_, _, gas) -> predecessor oph bytes (Some signature) >>=? fun result ->
match gas with Lwt.return (estimated_gas result) >>=? fun gas ->
| Limited { remaining } -> if Z.equal gas Z.zero then
let gas = Z.sub max_gas remaining in cctxt#message "Estimated gas: none" >>= fun () ->
if Z.equal gas Z.zero then return Z.zero
cctxt#message "Estimated gas: none" >>= fun () -> else
return Z.zero cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
else return (Z.add gas (Z.of_int 100))
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 -> end >>=? fun gas_limit ->
Alpha_services.Forge.Manager.transaction Alpha_services.Forge.Manager.transaction
cctxt block cctxt block
@ -152,12 +451,14 @@ let transfer (cctxt : #Proto_alpha.full)
let signed_bytes = Signature.concat bytes signature in let signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (contracts, operations, _) -> predecessor oph bytes (Some signature) >>=? fun result ->
cctxt#message "@[<v 2>This sequence of operations was run (including internal ones):@,%a@]" cctxt#message
(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 Shell_services.inject_operation
cctxt ~chain_id signed_bytes >>=? fun injected_oph -> cctxt ~chain_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ; assert (Operation_hash.equal oph injected_oph) ;
Lwt.return (originated_contracts result) >>=? fun contracts ->
return (oph, contracts) return (oph, contracts)
let reveal cctxt 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 -> Block_services.predecessor cctxt block >>=? fun predecessor ->
let oph = Operation_hash.hash_bytes [ signed_bytes ] in let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes signature >>=? function predecessor oph bytes signature >>=? fun result ->
| [ contract ], operations, _ -> Lwt.return (originated_contracts result) >>=? function
| [ contract ] ->
cctxt#message cctxt#message
"@[<v 2>This sequence of operations was run (including internal ones):@,%a@]" "@[<v 2>This sequence of operations was run:@,%a@]"
(Format.pp_print_list pp_internal_operation) operations >>= fun () -> pp_operation_result (Data_encoding.Binary.of_bytes_exn Operation.encoding signed_bytes, result) >>= fun () ->
Shell_services.inject_operation Shell_services.inject_operation
cctxt ?chain_id signed_bytes >>=? fun injected_oph -> cctxt ?chain_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ; assert (Operation_hash.equal oph injected_oph) ;
return (oph, contract) return (oph, contract)
| contracts, _, _ -> | contracts ->
failwith failwith
"The origination introduced %d contracts instead of one." "The origination introduced %d contracts instead of one."
(List.length contracts) (List.length contracts)
@ -205,7 +507,7 @@ let operation_submitted_message (cctxt : #Client_context.printer) ?(contracts =
Lwt_list.iter_s Lwt_list.iter_s
(fun c -> (fun c ->
cctxt#message cctxt#message
"New contract %a originated from a smart contract." "New contract %a originated."
Contract.pp c) Contract.pp c)
contracts >>= return contracts >>= return
@ -349,17 +651,14 @@ let originate_contract
let signed_bytes = Signature.concat bytes signature in let signed_bytes = Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Alpha_services.Helpers.apply_operation cctxt block Alpha_services.Helpers.apply_operation cctxt block
predecessor oph bytes (Some signature) >>=? fun (_, _, gas) -> predecessor oph bytes (Some signature) >>=? fun result ->
match gas with Lwt.return (estimated_gas result) >>=? fun gas ->
| Limited { remaining } -> if Z.equal gas Z.zero then
let gas = Z.sub max_gas remaining in cctxt#message "Estimated gas: none" >>= fun () ->
if Z.equal gas Z.zero then return Z.zero
cctxt#message "Estimated gas: none" >>= fun () -> else
return Z.zero cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
else return (Z.add gas (Z.of_int 100))
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 -> end >>=? fun gas_limit ->
Alpha_services.Forge.Manager.origination cctxt block Alpha_services.Forge.Manager.origination cctxt block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager ~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: val pp_internal_operation:
Format.formatter -> internal_operation -> unit Format.formatter -> internal_operation -> unit
val pp_operation_result :
Format.formatter -> (operation * Apply_operation_result.operation_result) -> unit
val source_to_keys: val source_to_keys:
#Proto_alpha.full -> #Proto_alpha.full ->
Block_services.block -> Block_services.block ->

5
src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL
View File

@ -31,8 +31,8 @@
"Block_header_repr", "Block_header_repr",
"Operation_repr", "Operation_repr",
"Manager_repr", "Manager_repr",
"Commitment_repr", "Commitment_repr",
"Parameters_repr", "Parameters_repr",
"Raw_context", "Raw_context",
"Storage_sigs", "Storage_sigs",
@ -64,6 +64,7 @@
"Baking", "Baking",
"Amendment", "Amendment",
"Apply_operation_result",
"Apply", "Apply",
"Services_registration", "Services_registration",

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

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

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

@ -19,7 +19,7 @@ val minimal_time:
val apply_operation: val apply_operation:
'a #RPC_context.simple -> 'a #RPC_context.simple ->
'a -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Signature.t option -> '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: val run_code:
'a #RPC_context.simple -> '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 Some baker in
Apply.apply_operation ctxt baker pred_block block_prio Apply.apply_operation ctxt baker pred_block block_prio
(Alpha_context.Operation.hash operation) operation (Alpha_context.Operation.hash operation) operation
>>=? fun { Apply.ctxt ; _ } -> >>=? fun (ctxt, _) ->
let op_count = op_count + 1 in let op_count = op_count + 1 in
return { data with ctxt ; op_count } 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 *)) ~script:({ code ; storage }, None (* TODO: initialize a big map from a map *))
~spendable ~delegatable ~spendable ~delegatable
>>=? fun (ctxt, contract) -> >>=? 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 logged_return descr (Item ((param_type, contract), rest), ctxt) in
let logged_return : let logged_return :
a stack * context -> a stack * context ->
@ -676,7 +676,7 @@ let rec interp
Contract.originate ctxt Contract.originate ctxt
~manager ~delegate ~balance ~manager ~delegate ~balance
?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract) -> ?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) logged_return (Item ((Unit_t, contract), rest), ctxt)
| Implicit_account, Item (key, rest) -> | Implicit_account, Item (key, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> 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.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 let operation
~tc ?(baker: Helpers_account.t option) ?(src: Helpers_account.t option) ~tc ?(baker: Helpers_account.t option) ?(src: Helpers_account.t option)
@ -20,8 +43,8 @@ let operation
pred_block_hash pred_block_hash
0 0
hash hash
operation >>=? fun { ctxt = tc ; contracts ; ignored_error } -> operation
return ((contracts, ignored_error), tc) >>=? bind_result
let transaction ~tc ?(fee = 0) ?baker 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 : val operation :
tc:context -> ?baker:Helpers_account.t -> ?src:Helpers_account.t -> tc:context -> ?baker:Helpers_account.t -> ?src:Helpers_account.t ->
Block_hash.t -> Tezos_base.Operation.shell_header -> proto_operation -> 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 : val transaction :
tc:context -> ?fee:int -> ?baker:Helpers_account.t -> Block_hash.t -> tc:context -> ?fee:int -> ?baker:Helpers_account.t -> Block_hash.t ->
Tezos_base.Operation.shell_header -> Helpers_account.t -> Helpers_account.t -> int -> 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 : val transaction_pred :
?tc:t -> pred:Helpers_block.result -> ?baker:Helpers_account.t -> ?tc:t -> pred:Helpers_block.result -> ?baker:Helpers_account.t ->
Helpers_account.t * Helpers_account.t * int * int option -> 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 : val script_origination :
tc:context -> Block_hash.t -> Tezos_base.Operation.shell_header -> tc:context -> Block_hash.t -> Tezos_base.Operation.shell_header ->
Script.t option -> Helpers_account.t -> int -> 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 : val origination :
tc:context -> ?baker:Helpers_account.t -> ?spendable:bool -> ?fee:int -> tc:context -> ?baker:Helpers_account.t -> ?spendable:bool -> ?fee:int ->
?delegatable:bool -> Block_hash.t -> Tezos_base.Operation.shell_header -> ?delegatable:bool -> Block_hash.t -> Tezos_base.Operation.shell_header ->
Helpers_account.t -> int -> 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 : val script_origination_pred :
?tc:t -> pred:Helpers_block.result -> Script.t * Helpers_account.t * int -> ?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 : val origination_pred :
?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result -> ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
Helpers_account.t * int * bool * bool * int -> 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 : val delegation :
tc:context -> ?baker:Helpers_account.t -> ?fee:int -> Block_hash.t -> tc:context -> ?baker:Helpers_account.t -> ?fee:int -> Block_hash.t ->
Tezos_base.Operation.shell_header -> Helpers_account.t -> public_key_hash -> 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 : val delegation_pred :
?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result -> ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
Helpers_account.t * public_key_hash * int -> 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 op = List.nth Helpers_account.bootstrap_accounts 0 in
let tc = Option.unopt ~default:pred.tezos_context tc in let tc = Option.unopt ~default:pred.tezos_context tc in
Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount) Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount)
>>=? fun ((dst, _), tc) -> >>=? fun (dst, tc) ->
let dst = List.hd dst in let dst = List.hd dst in
let ctxt = Helpers_cast.ctxt_of_tc tc in let ctxt = Helpers_cast.ctxt_of_tc tc in
let gas = Proto_alpha.Alpha_context.Constants.hard_gas_limit_per_operation 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 let src = List.hd Helpers.Account.bootstrap_accounts in
Lwt.return (parse_script code storage) >>=? fun script -> Lwt.return (parse_script code storage) >>=? fun script ->
Helpers.Apply.script_origination_pred Helpers.Apply.script_origination_pred
~tc ~pred (script , src, 100_00) >>=?? fun ((contracts, errs), tc) -> ~tc ~pred (script , src, 100_00) >>=?? fun (contracts, tc) ->
begin match errs with
| None | Some [] -> Proto_alpha.Error_monad.return ()
| Some (err :: _) -> Proto_alpha.Error_monad.fail err
end >>=?? fun () ->
begin match contracts with begin match contracts with
| [ contract ] -> return contract | [ contract ] -> return contract
| _ -> failwith "more than one contract" | _ -> failwith "more than one contract"
@ -103,11 +99,7 @@ let main () =
Helpers.Apply.operation ~tc Helpers.Apply.operation ~tc
~src pred.Helpers_block.hash ~src pred.Helpers_block.hash
(Helpers_block.get_op_header_res pred) (Helpers_block.get_op_header_res pred)
op >>=?? fun ((_, errs), tc) -> op >>=?? fun (_, tc) ->
begin match errs with
| None | Some [] -> Proto_alpha.Error_monad.return ()
| Some (err :: _) -> Proto_alpha.Error_monad.fail err
end >>=?? fun () ->
expect_big_map tc result >>=?? fun () -> expect_big_map tc result >>=?? fun () ->
debug "big map after call %s is ok" input ; debug "big map after call %s is ok" input ;
return tc in 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 transfer
account_a account_a
account_unknown_foo 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 () -> Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
debug "Reception" ; debug "Reception" ;
@ -62,7 +62,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
account_a account_a
account_b account_b
1000 1000
>>=? fun ((contracts, _), _) -> >>=? fun (contracts, _) ->
Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ; Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
debug "No contracts originated" ; debug "No contracts originated" ;
@ -71,7 +71,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
account_a account_a
account_b account_b
1000 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_a.contract, 998990) >>=? fun () ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () -> Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () ->
debug "Transfer balances" ; debug "Transfer balances" ;
@ -90,7 +90,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
~spendable: false ~spendable: false
account_a account_a
1000 1000
>>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) -> >>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, tc) ->
Assert.equal_int (List.length contracts) 1 ; Assert.equal_int (List.length contracts) 1 ;
let non_spendable = List.hd contracts in let non_spendable = List.hd contracts in
let account = {account_a with contract = non_spendable} in let account = {account_a with contract = non_spendable} in
@ -105,7 +105,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
~fee: 100 ~fee: 100
account_a account_a
1000 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 ; Assert.equal_int (List.length contracts) 1 ;
let contract_spendable = List.hd contracts in let contract_spendable = List.hd contracts in
let account_spendable = {account_a with contract = contract_spendable} 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 Proto_alpha
open Alpha_context
let name = "Isolate Michelson" let name = "Isolate Michelson"
module Logger = Logging.Make(struct let name = name end) module Logger = Logging.Make(struct let name = name end)
@ -44,6 +43,21 @@ let program param st code =
let quote s = "\"" ^ s ^ "\"" 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 parse_execute sb ?tc code_str param_str storage_str =
let param = parse_param param_str in let param = parse_param param_str in
let script = parse_script code_str storage_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 }) -> >>=?? fun (dst, { ctxt = tc ; operations = ops ; big_map_diff = bgm }) ->
let payer = let payer =
(List.hd Account.bootstrap_accounts).contract in (List.hd Account.bootstrap_accounts).contract in
Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>=?? fun (tc, err, _, ops) -> Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>= function
Contract.originated_from_current_nonce tc >>=?? fun contracts -> | Error result ->
match err with let _, err = extract_result result in
| None -> 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 let tc = Proto_alpha.Alpha_context.Gas.set_unlimited tc in
Proto_alpha.Alpha_context.Contract.get_storage tc dst >>=?? begin function Proto_alpha.Alpha_context.Contract.get_storage tc dst >>=?? begin function
| (_, None) -> assert false | (_, None) -> assert false
| (tc, Some st) -> return (st, ops, tc, contracts, bgm) | (tc, Some st) -> return (st, ops, tc, contracts, bgm)
end 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 test ctxt ?tc (file_name: string) (storage: string) (input: string) =
let full_path = contract_path // file_name ^ ".tz" in 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 *) (* Delegatable should change delegate *)
originate root ~delegatable: true account_a 200 originate root ~delegatable: true account_a 200
>>=? fun ((contracts, _errs), tc) -> >>=? fun (contracts, tc) ->
let contract = List.hd contracts in let contract = List.hd contracts in
let account_ac = {account_a with contract} in let account_ac = {account_a with contract} in
delegate root ~tc account_ac account_b.hpub >>= Assert.ok ~msg: __LOC__ >>= fun _ -> delegate root ~tc account_ac account_b.hpub >>= Assert.ok ~msg: __LOC__ >>= fun _ ->
(* Not-Delegatable should not change delegate *) (* Not-Delegatable should not change delegate *)
originate root ~delegatable: false account_a 200 originate root ~delegatable: false account_a 200
>>=? fun ((contracts, _errs), tc) -> >>=? fun (contracts, tc) ->
let contract = List.hd contracts in let contract = List.hd contracts in
let account_a = {account_a with contract} in let account_a = {account_a with contract} in
delegate root ~tc account_a account_b.hpub >>= Assert.wrap >>= fun res -> 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. *) (* Send 10 tz to unknown account. *)
transfer (account_a, account_unknown_foo, 10000) >>= 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 () -> Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
debug "Reception" ; debug "Reception" ;
(* Unknown account transfers back tz. *) (* Unknown account transfers back tz. *)
transfer ~tc (account_unknown_foo, account_a, 9990) >>= transfer ~tc (account_unknown_foo, account_a, 9990) >>=
Assert.ok_contract >>=? fun _ -> Assert.ok >>=? fun _ ->
debug "Transfer back" ; debug "Transfer back" ;
(* Check that a basic transfer originates no contracts. *) (* 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) ; Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
debug "No contracts originated" ; debug "No contracts originated" ;
(* Check sender/receiver balance post transaction *) (* Check sender/receiver balance post transaction *)
transfer (account_a, account_b, 1000) >>= 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 -> 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_a.contract, init_amount * 100 - 1000 - 10) >>=? fun () ->
Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? 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 *) (* Check non-spendability of a non-spendable contract *)
(* TODO: Unspecified economic error: should be more specific. *) (* TODO: Unspecified economic error: should be more specific. *)
originate (account_a, 1000, false, true, 0) 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 ; Assert.equal_int (List.length contracts) 1 ;
let non_spendable = List.hd contracts in let non_spendable = List.hd contracts in
let account = {account_a with contract = non_spendable} 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 *) (* Check spendability of a spendable contract *)
originate (account_a, 1000, true, true, 100) 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 ; Assert.equal_int (List.length contracts) 1 ;
let contract_spendable = List.hd contracts in let contract_spendable = List.hd contracts in
let account_spendable = {account_a with contract = contract_spendable} in let account_spendable = {account_a with contract = contract_spendable} in