diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 972ec6f86..42ca0712c 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -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 "@[" ; begin match operation with | Alpha_context.Transaction { destination ; amount ; parameters } -> Format.fprintf ppf - "@[Transaction:@,\ - Of: %a@,\ + "@[%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: @[%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 "@[Origination:@,\ + Format.fprintf ppf "@[%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 - "@,@[Script:@,%a\ - @,@[Initial storage:@,%a@]" + "@,@[Script:@ %a\ + @,@[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 - "@[Revelation of manager public key:@,\ + "@[%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 - "@[Delegation:@,\ + "@[%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 - "@[Delegation:@,\ + "@[%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 "@[%a@]" + (Format.pp_print_list pp_one) balance_updates + +let pp_operation_result ppf ({ contents ; _ }, operation_result) = + Format.fprintf ppf "@[" ; + 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 + "@[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 + "@[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 + "@[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 + "@[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 + "@[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 + "@[Proposals:@,\ + From: %a@,\ + Period: %a@,\ + Protocols:@,\ + \ @[%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 + "@[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 + "@[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 + "@[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 + "@[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 "@,@[Originated contracts:@,%a@]" + (Format.pp_print_list Contract.pp) contracts + end ; + begin match storage with + | None -> () + | Some expr -> + Format.fprintf ppf "@,@[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 "@,@[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 + "@[@[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 - 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 + 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)) 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 "@[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 + "@[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 - "@[This sequence of operations was run (including internal ones):@,%a@]" - (Format.pp_print_list pp_internal_operation) operations >>= fun () -> + "@[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 - 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 + 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)) end >>=? fun gas_limit -> Alpha_services.Forge.Manager.origination cctxt block ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index c3a06b07d..a9bc08ca1 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL index 6d2f2d40f..dd6fbba25 100644 --- a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL @@ -31,8 +31,8 @@ "Block_header_repr", "Operation_repr", "Manager_repr", - "Commitment_repr", - "Parameters_repr", + "Commitment_repr", + "Parameters_repr", "Raw_context", "Storage_sigs", @@ -64,6 +64,7 @@ "Baking", "Amendment", + "Apply_operation_result", "Apply", "Services_registration", diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index bb6082319..394e3fdc2 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -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,58 +370,95 @@ 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 - if internal then - Contract.spend_from_script ctxt source amount - else - Contract.spend ctxt source amount - end >>=? 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, []) - | Some arg -> - match Micheline.root arg with - | Prim (_, D_Unit, [], _) -> - return (ctxt, None, Tez.zero, []) - | _ -> fail (Bad_contract_parameter (destination, None, parameters)) - end - | Some script -> - let call_contract 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 } -> - 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 +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 + else + 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 () + | Some arg -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + return () + | _ -> fail (Bad_contract_parameter (destination, None, parameters)) + 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 -> + 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, _, _) -> - 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 + 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 + 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 ; spendable ; delegatable ; credit } -> begin match script with @@ -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 diff --git a/src/proto_alpha/lib_protocol/src/apply_operation_result.ml b/src/proto_alpha/lib_protocol/src/apply_operation_result.ml new file mode 100644 index 000000000..4d4bde1b9 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/apply_operation_result.ml @@ -0,0 +1,277 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 })) ] diff --git a/src/proto_alpha/lib_protocol/src/apply_operation_result.mli b/src/proto_alpha/lib_protocol/src/apply_operation_result.mli new file mode 100644 index 000000000..2d8702329 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/apply_operation_result.mli @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/proto_alpha/lib_protocol/src/fees.ml b/src/proto_alpha/lib_protocol/src/fees.ml index 8db8f4609..232d49638 100644 --- a/src/proto_alpha/lib_protocol/src/fees.ml +++ b/src/proto_alpha/lib_protocol/src/fees.ml @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/src/fees.mli b/src/proto_alpha/lib_protocol/src/fees.mli index d9aa9ae21..b38675cd3 100644 --- a/src/proto_alpha/lib_protocol/src/fees.mli +++ b/src/proto_alpha/lib_protocol/src/fees.mli @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index ba4fa5825..aca320f7b 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.mli b/src/proto_alpha/lib_protocol/src/helpers_services.mli index 82d2fc89f..d38ec5473 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.mli +++ b/src/proto_alpha/lib_protocol/src/helpers_services.mli @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/src/main.ml b/src/proto_alpha/lib_protocol/src/main.ml index 34494c7ca..88f2cba62 100644 --- a/src/proto_alpha/lib_protocol/src/main.ml +++ b/src/proto_alpha/lib_protocol/src/main.ml @@ -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 } diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index d30c53e2e..c26564f20 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml index 0b4b09d6f..cca231890 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli b/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli index 7d0c289ac..f8a75f606 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml index 892bfe4b5..b758b661c 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/test_big_maps.ml b/src/proto_alpha/lib_protocol/test/test_big_maps.ml index 78f8ffc86..517d23b43 100644 --- a/src/proto_alpha/lib_protocol/test/test_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_big_maps.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/test_dsl.ml b/src/proto_alpha/lib_protocol/test/test_dsl.ml index 38ed5bb14..1474735dc 100644 --- a/src/proto_alpha/lib_protocol/test/test_dsl.ml +++ b/src/proto_alpha/lib_protocol/test/test_dsl.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/test_michelson.ml b/src/proto_alpha/lib_protocol/test/test_michelson.ml index b02690360..f7313d502 100644 --- a/src/proto_alpha/lib_protocol/test/test_michelson.ml +++ b/src/proto_alpha/lib_protocol/test/test_michelson.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/test/test_origination.ml b/src/proto_alpha/lib_protocol/test/test_origination.ml index b5c2eb88c..076da620c 100644 --- a/src/proto_alpha/lib_protocol/test/test_origination.ml +++ b/src/proto_alpha/lib_protocol/test/test_origination.ml @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/test/test_transaction.ml b/src/proto_alpha/lib_protocol/test/test_transaction.ml index abc272dea..e3f0704e6 100644 --- a/src/proto_alpha/lib_protocol/test/test_transaction.ml +++ b/src/proto_alpha/lib_protocol/test/test_transaction.ml @@ -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