(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Tezos Protocol Implementation - Main Entry Points *)
open Alpha_context
type error += Wrong_voting_period of Voting_period.t * Voting_period.t
(* `Temporary *)
type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t
(* `Temporary *)
type error += Duplicate_endorsement of Signature.Public_key_hash.t
(* `Branch *)
type error += Invalid_endorsement_level
type error += Invalid_commitment of {expected : bool}
type error += Internal_operation_replay of packed_internal_operation
type error += Invalid_double_endorsement_evidence (* `Permanent *)
type error +=
| Inconsistent_double_endorsement_evidence of {
delegate1 : Signature.Public_key_hash.t;
delegate2 : Signature.Public_key_hash.t;
}
(* `Permanent *)
type error += Unrequired_double_endorsement_evidence (* `Branch*)
type error +=
| Too_early_double_endorsement_evidence of {
level : Raw_level.t;
current : Raw_level.t;
}
(* `Temporary *)
type error +=
| Outdated_double_endorsement_evidence of {
level : Raw_level.t;
last : Raw_level.t;
}
(* `Permanent *)
type error +=
| Invalid_double_baking_evidence of {
hash1 : Block_hash.t;
level1 : Int32.t;
hash2 : Block_hash.t;
level2 : Int32.t;
}
(* `Permanent *)
type error +=
| Inconsistent_double_baking_evidence of {
delegate1 : Signature.Public_key_hash.t;
delegate2 : Signature.Public_key_hash.t;
}
(* `Permanent *)
type error += Unrequired_double_baking_evidence (* `Branch*)
type error +=
| Too_early_double_baking_evidence of {
level : Raw_level.t;
current : Raw_level.t;
}
(* `Temporary *)
type error +=
| Outdated_double_baking_evidence of {
level : Raw_level.t;
last : Raw_level.t;
}
(* `Permanent *)
type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t}
type error += Multiple_revelation
type error += Gas_quota_exceeded_init_deserialize (* Permanent *)
type error +=
| Not_enough_endorsements_for_priority of {
required : int;
priority : int;
endorsements : int;
timestamp : Time.t;
}
let () =
register_error_kind
`Temporary
~id:"operation.wrong_endorsement_predecessor"
~title:"Wrong endorsement predecessor"
~description:
"Trying to include an endorsement in a block that is not the successor \
of the endorsed one"
~pp:(fun ppf (e, p) ->
Format.fprintf
ppf
"Wrong predecessor %a, expected %a"
Block_hash.pp
p
Block_hash.pp
e)
Data_encoding.(
obj2
(req "expected" Block_hash.encoding)
(req "provided" Block_hash.encoding))
(function
| Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None)
(fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ;
register_error_kind
`Temporary
~id:"operation.wrong_voting_period"
~title:"Wrong voting period"
~description:
"Trying to onclude a proposal or ballot meant for another voting period"
~pp:(fun ppf (e, p) ->
Format.fprintf
ppf
"Wrong voting period %a, current is %a"
Voting_period.pp
p
Voting_period.pp
e)
Data_encoding.(
obj2
(req "current" Voting_period.encoding)
(req "provided" Voting_period.encoding))
(function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
(fun (e, p) -> Wrong_voting_period (e, p)) ;
register_error_kind
`Branch
~id:"operation.duplicate_endorsement"
~title:"Duplicate endorsement"
~description:"Two endorsements received from same delegate"
~pp:(fun ppf k ->
Format.fprintf
ppf
"Duplicate endorsement from delegate %a (possible replay attack)."
Signature.Public_key_hash.pp_short
k)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function Duplicate_endorsement k -> Some k | _ -> None)
(fun k -> Duplicate_endorsement k) ;
register_error_kind
`Temporary
~id:"operation.invalid_endorsement_level"
~title:"Unexpected level in endorsement"
~description:
"The level of an endorsement is inconsistent with the provided block \
hash."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.")
Data_encoding.unit
(function Invalid_endorsement_level -> Some () | _ -> None)
(fun () -> Invalid_endorsement_level) ;
register_error_kind
`Permanent
~id:"block.invalid_commitment"
~title:"Invalid commitment in block header"
~description:"The block header has invalid commitment."
~pp:(fun ppf expected ->
if expected then
Format.fprintf ppf "Missing seed's nonce commitment in block header."
else
Format.fprintf
ppf
"Unexpected seed's nonce commitment in block header.")
Data_encoding.(obj1 (req "expected" bool))
(function Invalid_commitment {expected} -> Some expected | _ -> None)
(fun expected -> Invalid_commitment {expected}) ;
register_error_kind
`Permanent
~id:"internal_operation_replay"
~title:"Internal operation replay"
~description:"An internal operation was emitted twice by a script"
~pp:(fun ppf (Internal_operation {nonce; _}) ->
Format.fprintf
ppf
"Internal operation %d was emitted twice by a script"
nonce)
Operation.internal_operation_encoding
(function Internal_operation_replay op -> Some op | _ -> None)
(fun op -> Internal_operation_replay op) ;
register_error_kind
`Permanent
~id:"block.invalid_double_endorsement_evidence"
~title:"Invalid double endorsement evidence"
~description:"A double-endorsement evidence is malformed"
~pp:(fun ppf () ->
Format.fprintf ppf "Malformed double-endorsement evidence")
Data_encoding.empty
(function Invalid_double_endorsement_evidence -> Some () | _ -> None)
(fun () -> Invalid_double_endorsement_evidence) ;
register_error_kind
`Permanent
~id:"block.inconsistent_double_endorsement_evidence"
~title:"Inconsistent double endorsement evidence"
~description:
"A double-endorsement evidence is inconsistent (two distinct delegates)"
~pp:(fun ppf (delegate1, delegate2) ->
Format.fprintf
ppf
"Inconsistent double-endorsement evidence (distinct delegate: %a and \
%a)"
Signature.Public_key_hash.pp_short
delegate1
Signature.Public_key_hash.pp_short
delegate2)
Data_encoding.(
obj2
(req "delegate1" Signature.Public_key_hash.encoding)
(req "delegate2" Signature.Public_key_hash.encoding))
(function
| Inconsistent_double_endorsement_evidence {delegate1; delegate2} ->
Some (delegate1, delegate2)
| _ ->
None)
(fun (delegate1, delegate2) ->
Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ;
register_error_kind
`Branch
~id:"block.unrequired_double_endorsement_evidence"
~title:"Unrequired double endorsement evidence"
~description:"A double-endorsement evidence is unrequired"
~pp:(fun ppf () ->
Format.fprintf
ppf
"A valid double-endorsement operation cannot be applied: the \
associated delegate has previously been denunciated in this cycle.")
Data_encoding.empty
(function Unrequired_double_endorsement_evidence -> Some () | _ -> None)
(fun () -> Unrequired_double_endorsement_evidence) ;
register_error_kind
`Temporary
~id:"block.too_early_double_endorsement_evidence"
~title:"Too early double endorsement evidence"
~description:"A double-endorsement evidence is in the future"
~pp:(fun ppf (level, current) ->
Format.fprintf
ppf
"A double-endorsement evidence is in the future (current level: %a, \
endorsement level: %a)"
Raw_level.pp
current
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
(function
| Too_early_double_endorsement_evidence {level; current} ->
Some (level, current)
| _ ->
None)
(fun (level, current) ->
Too_early_double_endorsement_evidence {level; current}) ;
register_error_kind
`Permanent
~id:"block.outdated_double_endorsement_evidence"
~title:"Outdated double endorsement evidence"
~description:"A double-endorsement evidence is outdated."
~pp:(fun ppf (level, last) ->
Format.fprintf
ppf
"A double-endorsement evidence is outdated (last acceptable level: \
%a, endorsement level: %a)"
Raw_level.pp
last
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
(function
| Outdated_double_endorsement_evidence {level; last} ->
Some (level, last)
| _ ->
None)
(fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ;
register_error_kind
`Permanent
~id:"block.invalid_double_baking_evidence"
~title:"Invalid double baking evidence"
~description:
"A double-baking evidence is inconsistent (two distinct level)"
~pp:(fun ppf (hash1, level1, hash2, level2) ->
Format.fprintf
ppf
"Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)"
Block_hash.pp
hash1
Block_hash.pp
hash2
level1
level2)
Data_encoding.(
obj4
(req "hash1" Block_hash.encoding)
(req "level1" int32)
(req "hash2" Block_hash.encoding)
(req "level2" int32))
(function
| Invalid_double_baking_evidence {hash1; level1; hash2; level2} ->
Some (hash1, level1, hash2, level2)
| _ ->
None)
(fun (hash1, level1, hash2, level2) ->
Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ;
register_error_kind
`Permanent
~id:"block.inconsistent_double_baking_evidence"
~title:"Inconsistent double baking evidence"
~description:
"A double-baking evidence is inconsistent (two distinct delegates)"
~pp:(fun ppf (delegate1, delegate2) ->
Format.fprintf
ppf
"Inconsistent double-baking evidence (distinct delegate: %a and %a)"
Signature.Public_key_hash.pp_short
delegate1
Signature.Public_key_hash.pp_short
delegate2)
Data_encoding.(
obj2
(req "delegate1" Signature.Public_key_hash.encoding)
(req "delegate2" Signature.Public_key_hash.encoding))
(function
| Inconsistent_double_baking_evidence {delegate1; delegate2} ->
Some (delegate1, delegate2)
| _ ->
None)
(fun (delegate1, delegate2) ->
Inconsistent_double_baking_evidence {delegate1; delegate2}) ;
register_error_kind
`Branch
~id:"block.unrequired_double_baking_evidence"
~title:"Unrequired double baking evidence"
~description:"A double-baking evidence is unrequired"
~pp:(fun ppf () ->
Format.fprintf
ppf
"A valid double-baking operation cannot be applied: the associated \
delegate has previously been denunciated in this cycle.")
Data_encoding.empty
(function Unrequired_double_baking_evidence -> Some () | _ -> None)
(fun () -> Unrequired_double_baking_evidence) ;
register_error_kind
`Temporary
~id:"block.too_early_double_baking_evidence"
~title:"Too early double baking evidence"
~description:"A double-baking evidence is in the future"
~pp:(fun ppf (level, current) ->
Format.fprintf
ppf
"A double-baking evidence is in the future (current level: %a, \
baking level: %a)"
Raw_level.pp
current
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
(function
| Too_early_double_baking_evidence {level; current} ->
Some (level, current)
| _ ->
None)
(fun (level, current) -> Too_early_double_baking_evidence {level; current}) ;
register_error_kind
`Permanent
~id:"block.outdated_double_baking_evidence"
~title:"Outdated double baking evidence"
~description:"A double-baking evidence is outdated."
~pp:(fun ppf (level, last) ->
Format.fprintf
ppf
"A double-baking evidence is outdated (last acceptable level: %a, \
baking level: %a)"
Raw_level.pp
last
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
(function
| Outdated_double_baking_evidence {level; last} ->
Some (level, last)
| _ ->
None)
(fun (level, last) -> Outdated_double_baking_evidence {level; last}) ;
register_error_kind
`Permanent
~id:"operation.invalid_activation"
~title:"Invalid activation"
~description:
"The given key and secret do not correspond to any existing \
preallocated contract"
~pp:(fun ppf pkh ->
Format.fprintf
ppf
"Invalid activation. The public key %a does not match any commitment."
Ed25519.Public_key_hash.pp
pkh)
Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding))
(function Invalid_activation {pkh} -> Some pkh | _ -> None)
(fun pkh -> Invalid_activation {pkh}) ;
register_error_kind
`Permanent
~id:"block.multiple_revelation"
~title:"Multiple revelations were included in a manager operation"
~description:
"A manager operation should not contain more than one revelation"
~pp:(fun ppf () ->
Format.fprintf
ppf
"Multiple revelations were included in a manager operation")
Data_encoding.empty
(function Multiple_revelation -> Some () | _ -> None)
(fun () -> Multiple_revelation) ;
register_error_kind
`Permanent
~id:"gas_exhausted.init_deserialize"
~title:"Not enough gas for initial deserialization of script expresions"
~description:
"Gas limit was not high enough to deserialize the transaction \
parameters or origination script code or initial storage, making the \
operation impossible to parse within the provided gas bounds."
Data_encoding.empty
(function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
(fun () -> Gas_quota_exceeded_init_deserialize) ;
register_error_kind
`Permanent
~id:"operation.not_enought_endorsements_for_priority"
~title:"Not enough endorsements for priority"
~description:
"The block being validated does not include the required minimum number \
of endorsements for this priority."
~pp:(fun ppf (required, endorsements, priority, timestamp) ->
Format.fprintf
ppf
"Wrong number of endorsements (%i) for priority (%i), %i are expected \
at %a"
endorsements
priority
required
Time.pp_hum
timestamp)
Data_encoding.(
obj4
(req "required" int31)
(req "endorsements" int31)
(req "priority" int31)
(req "timestamp" Time.encoding))
(function
| Not_enough_endorsements_for_priority
{required; endorsements; priority; timestamp} ->
Some (required, endorsements, priority, timestamp)
| _ ->
None)
(fun (required, endorsements, priority, timestamp) ->
Not_enough_endorsements_for_priority
{required; endorsements; priority; timestamp})
open Apply_results
let apply_manager_operation_content :
type kind.
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
payer:Contract.t ->
source:Contract.t ->
chain_id:Chain_id.t ->
internal:bool ->
kind manager_operation ->
( context
* kind successful_manager_operation_result
* packed_internal_operation list )
tzresult
Lwt.t =
fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
let before_operation =
(* This context is not used for backtracking. Only to compute
gas consumption and originations for the operation result. *)
ctxt
in
Contract.must_exist ctxt source
>>=? fun () ->
Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation)
>>=? fun ctxt ->
match operation with
| Reveal _ ->
return
(* No-op: action already performed by `precheck_manager_contents`. *)
( ctxt,
( Reveal_result
{consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}
: kind successful_manager_operation_result ),
[] )
| Transaction {amount; parameters; destination; entrypoint} -> (
Contract.spend ctxt source amount
>>=? fun ctxt ->
( match Contract.is_implicit destination with
| None ->
return (ctxt, [], false)
| Some _ -> (
Contract.allocated ctxt destination
>>=? function
| true ->
return (ctxt, [], false)
| false ->
Fees.origination_burn ctxt
>>=? fun (ctxt, origination_burn) ->
return
( ctxt,
[(Delegate.Contract payer, Delegate.Debited origination_burn)],
true ) ) )
>>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract)
->
Contract.credit ctxt destination amount
>>=? fun ctxt ->
Contract.get_script ctxt destination
>>=? fun (ctxt, script) ->
match script with
| None ->
( match entrypoint with
| "default" ->
return ()
| entrypoint ->
fail (Script_tc_errors.No_such_entrypoint entrypoint) )
>>=? (fun () ->
Script.force_decode ctxt parameters
>>=? fun (arg, ctxt) ->
(* see [note] *)
(* [note]: for toplevel ops, cost is nil since the
lazy value has already been forced at precheck, so
we compute and consume the full cost again *)
let cost_arg = Script.deserialized_cost arg in
Lwt.return (Gas.consume ctxt cost_arg)
>>=? fun ctxt ->
match Micheline.root arg with
| Prim (_, D_Unit, [], _) ->
(* Allow [Unit] parameter to non-scripted contracts. *)
return ctxt
| _ ->
fail
(Script_interpreter.Bad_contract_parameter destination))
>>=? fun ctxt ->
let result =
Transaction_result
{
storage = None;
big_map_diff = None;
balance_updates =
Delegate.cleanup_balance_updates
( [ (Delegate.Contract source, Delegate.Debited amount);
(Contract destination, Credited amount) ]
@ maybe_burn_balance_update );
originated_contracts = [];
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = Z.zero;
paid_storage_size_diff = Z.zero;
allocated_destination_contract;
}
in
return (ctxt, result, [])
| Some script ->
Script.force_decode ctxt parameters
>>=? fun (parameter, ctxt) ->
(* see [note] *)
let cost_parameter = Script.deserialized_cost parameter in
Lwt.return (Gas.consume ctxt cost_parameter)
>>=? fun ctxt ->
let step_constants =
let open Script_interpreter in
{source; payer; self = destination; amount; chain_id}
in
Script_interpreter.execute
ctxt
mode
step_constants
~script
~parameter
~entrypoint
>>=? fun {ctxt; storage; big_map_diff; operations} ->
Contract.update_script_storage ctxt destination storage big_map_diff
>>=? fun ctxt ->
Fees.record_paid_storage_space ctxt destination
>>=? fun (ctxt, new_size, paid_storage_size_diff, fees) ->
Contract.originated_from_current_nonce
~since:before_operation
~until:ctxt
>>=? fun originated_contracts ->
let result =
Transaction_result
{
storage = Some storage;
big_map_diff;
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract payer, Debited fees);
(Contract source, Debited amount);
(Contract destination, Credited amount) ];
originated_contracts;
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = new_size;
paid_storage_size_diff;
allocated_destination_contract;
}
in
return (ctxt, result, operations) )
| Origination {delegate; script; preorigination; credit} ->
Script.force_decode ctxt script.storage
>>=? fun (unparsed_storage, ctxt) ->
(* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage))
>>=? fun ctxt ->
Script.force_decode ctxt script.code
>>=? fun (unparsed_code, ctxt) ->
(* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code))
>>=? fun ctxt ->
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.collect_big_maps
ctxt
parsed_script.storage_type
parsed_script.storage
>>=? fun (to_duplicate, ctxt) ->
let to_update = Script_ir_translator.no_big_map_id in
Script_ir_translator.extract_big_map_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate
~to_update
~temporary:false
>>=? fun (storage, big_map_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
parsed_script.storage_type
storage
>>=? fun (storage, ctxt) ->
let storage = Script.lazy_expr (Micheline.strip_locations storage) in
let script = {script with storage} in
Contract.spend ctxt source credit
>>=? fun ctxt ->
( match preorigination with
| Some contract ->
assert internal ;
(* The preorigination field is only used to early return
the address of an originated contract in Michelson.
It cannot come from the outside. *)
return (ctxt, contract)
| None ->
Contract.fresh_contract_from_current_nonce ctxt )
>>=? fun (ctxt, contract) ->
Contract.originate
ctxt
contract
~delegate
~balance:credit
~script:(script, big_map_diff)
>>=? fun ctxt ->
Fees.origination_burn ctxt
>>=? fun (ctxt, origination_burn) ->
Fees.record_paid_storage_space ctxt contract
>>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
let result =
Origination_result
{
big_map_diff;
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract payer, Debited fees);
(Contract payer, Debited origination_burn);
(Contract source, Debited credit);
(Contract contract, Credited credit) ];
originated_contracts = [contract];
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = size;
paid_storage_size_diff;
}
in
return (ctxt, result, [])
| Delegation delegate ->
Delegate.set ctxt source delegate
>>=? fun ctxt ->
return
( ctxt,
Delegation_result
{consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
[] )
let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
let rec apply ctxt applied worklist =
match worklist with
| [] ->
Lwt.return (`Success ctxt, List.rev applied)
| Internal_operation ({source; operation; nonce} as op) :: rest -> (
( if internal_nonce_already_recorded ctxt nonce then
fail (Internal_operation_replay (Internal_operation op))
else
let ctxt = record_internal_nonce ctxt nonce in
apply_manager_operation_content
ctxt
mode
~source
~payer
~chain_id
~internal:true
operation )
>>= function
| Error errors ->
let result =
Internal_operation_result
(op, Failed (manager_kind op.operation, errors))
in
let skipped =
List.rev_map
(fun (Internal_operation op) ->
Internal_operation_result
(op, Skipped (manager_kind op.operation)))
rest
in
Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
| Ok (ctxt, result, emitted) ->
apply
ctxt
(Internal_operation_result (op, Applied result) :: applied)
(rest @ emitted) )
in
apply ctxt [] ops
let precheck_manager_contents (type kind) ctxt chain_id raw_operation
(op : kind Kind.manager contents) : context tzresult Lwt.t =
let (Manager_operation
{source; fee; counter; operation; gas_limit; storage_limit}) =
op
in
Lwt.return (Gas.check_limit ctxt gas_limit)
>>=? fun () ->
let ctxt = Gas.set_limit ctxt gas_limit in
Lwt.return (Fees.check_storage_limit ctxt storage_limit)
>>=? fun () ->
Contract.must_be_allocated ctxt (Contract.implicit_contract source)
>>=? fun () ->
Contract.check_counter_increment ctxt source counter
>>=? fun () ->
( match operation with
| Reveal pk ->
Contract.reveal_manager_key ctxt source pk
| Transaction {parameters; _} ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Gas_quota_exceeded_init_deserialize
@@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters)
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt parameters
>>|? fun (_arg, ctxt) -> ctxt
| Origination {script; _} ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Gas_quota_exceeded_init_deserialize
@@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code)
>>? fun ctxt ->
Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)
)
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.code
>>=? fun (_code, ctxt) ->
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.storage
>>|? fun (_storage, ctxt) -> ctxt
| _ ->
return ctxt )
>>=? fun ctxt ->
Contract.get_manager_key ctxt source
>>=? fun public_key ->
(* Currently, the `raw_operation` only contains one signature, so
all operations are required to be from the same manager. This may
change in the future, allowing several managers to group-sign a
sequence of transactions. *)
Operation.check_signature public_key chain_id raw_operation
>>=? fun () ->
Contract.increment_counter ctxt source
>>=? fun ctxt ->
Contract.spend ctxt (Contract.implicit_contract source) fee
>>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt
let apply_manager_contents (type kind) ctxt mode chain_id
(op : kind Kind.manager contents) :
( [`Success of context | `Failure]
* kind manager_operation_result
* packed_internal_operation_result list )
Lwt.t =
let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in
let ctxt = Gas.set_limit ctxt gas_limit in
let ctxt = Fees.start_counting_storage_fees ctxt in
let source = Contract.implicit_contract source in
apply_manager_operation_content
ctxt
mode
~source
~payer:source
~internal:false
~chain_id
operation
>>= function
| Ok (ctxt, operation_results, internal_operations) -> (
apply_internal_manager_operations
ctxt
mode
~payer:source
~chain_id
internal_operations
>>= function
| (`Success ctxt, internal_operations_results) -> (
Fees.burn_storage_fees ctxt ~storage_limit ~payer:source
>>= function
| Ok ctxt ->
Lwt.return
( `Success ctxt,
Applied operation_results,
internal_operations_results )
| Error errors ->
Lwt.return
( `Failure,
Backtracked (operation_results, Some errors),
internal_operations_results ) )
| (`Failure, internal_operations_results) ->
Lwt.return
(`Failure, Applied operation_results, internal_operations_results)
)
| Error errors ->
Lwt.return (`Failure, Failed (manager_kind operation, errors), [])
let skipped_operation_result :
type kind. kind manager_operation -> kind manager_operation_result =
function
| operation -> (
match operation with
| Reveal _ ->
Applied
( Reveal_result {consumed_gas = Z.zero}
: kind successful_manager_operation_result )
| _ ->
Skipped (manager_kind operation) )
let rec mark_skipped :
type kind.
baker:Signature.Public_key_hash.t ->
Level.t ->
kind Kind.manager contents_list ->
kind Kind.manager contents_result_list =
fun ~baker level -> function
| Single (Manager_operation {source; fee; operation}) ->
let source = Contract.implicit_contract source in
Single_result
(Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result = skipped_operation_result operation;
internal_operation_results = [];
})
| Cons (Manager_operation {source; fee; operation}, rest) ->
let source = Contract.implicit_contract source in
Cons_result
( Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result = skipped_operation_result operation;
internal_operation_results = [];
},
mark_skipped ~baker level rest )
let rec precheck_manager_contents_list :
type kind.
Alpha_context.t ->
Chain_id.t ->
_ Operation.t ->
kind Kind.manager contents_list ->
context tzresult Lwt.t =
fun ctxt chain_id raw_operation contents_list ->
match contents_list with
| Single (Manager_operation _ as op) ->
precheck_manager_contents ctxt chain_id raw_operation op
| Cons ((Manager_operation _ as op), rest) ->
precheck_manager_contents ctxt chain_id raw_operation op
>>=? fun ctxt ->
precheck_manager_contents_list ctxt chain_id raw_operation rest
let rec apply_manager_contents_list_rec :
type kind.
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
public_key_hash ->
Chain_id.t ->
kind Kind.manager contents_list ->
([`Success of context | `Failure] * kind Kind.manager contents_result_list)
Lwt.t =
fun ctxt mode baker chain_id contents_list ->
let level = Level.current ctxt in
match contents_list with
| Single (Manager_operation {source; fee; _} as op) ->
let source = Contract.implicit_contract source in
apply_manager_contents ctxt mode chain_id op
>>= fun (ctxt_result, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
Lwt.return (ctxt_result, Single_result result)
| Cons ((Manager_operation {source; fee; _} as op), rest) -> (
let source = Contract.implicit_contract source in
apply_manager_contents ctxt mode chain_id op
>>= function
| (`Failure, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
Lwt.return
(`Failure, Cons_result (result, mark_skipped ~baker level rest))
| (`Success ctxt, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
apply_manager_contents_list_rec ctxt mode baker chain_id rest
>>= fun (ctxt_result, results) ->
Lwt.return (ctxt_result, Cons_result (result, results)) )
let mark_backtracked results =
let rec mark_contents_list :
type kind.
kind Kind.manager contents_result_list ->
kind Kind.manager contents_result_list = function
| Single_result (Manager_operation_result op) ->
Single_result
(Manager_operation_result
{
balance_updates = op.balance_updates;
operation_result =
mark_manager_operation_result op.operation_result;
internal_operation_results =
List.map
mark_internal_operation_results
op.internal_operation_results;
})
| Cons_result (Manager_operation_result op, rest) ->
Cons_result
( Manager_operation_result
{
balance_updates = op.balance_updates;
operation_result =
mark_manager_operation_result op.operation_result;
internal_operation_results =
List.map
mark_internal_operation_results
op.internal_operation_results;
},
mark_contents_list rest )
and mark_internal_operation_results
(Internal_operation_result (kind, result)) =
Internal_operation_result (kind, mark_manager_operation_result result)
and mark_manager_operation_result :
type kind. kind manager_operation_result -> kind manager_operation_result
= function
| (Failed _ | Skipped _ | Backtracked _) as result ->
result
| Applied (Reveal_result _) as result ->
result
| Applied result ->
Backtracked (result, None)
in
mark_contents_list results
let apply_manager_contents_list ctxt mode baker chain_id contents_list =
apply_manager_contents_list_rec ctxt mode baker chain_id contents_list
>>= fun (ctxt_result, results) ->
match ctxt_result with
| `Failure ->
Lwt.return (ctxt (* backtracked *), mark_backtracked results)
| `Success ctxt ->
Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results)
let apply_contents_list (type kind) ctxt chain_id mode pred_block baker
(operation : kind operation) (contents_list : kind contents_list) :
(context * kind contents_result_list) tzresult Lwt.t =
match contents_list with
| Single (Endorsement {level}) ->
let block = operation.shell.branch in
fail_unless
(Block_hash.equal block pred_block)
(Wrong_endorsement_predecessor (pred_block, block))
>>=? fun () ->
let current_level = (Level.current ctxt).level in
fail_unless
Raw_level.(succ level = current_level)
Invalid_endorsement_level
>>=? fun () ->
Baking.check_endorsement_rights ctxt chain_id operation
>>=? fun (delegate, slots, used) ->
if used then fail (Duplicate_endorsement delegate)
else
let ctxt = record_endorsement ctxt delegate in
let gap = List.length slots in
Lwt.return
Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap)
>>=? fun deposit ->
Delegate.freeze_deposit ctxt delegate deposit
>>=? fun ctxt ->
Global.get_block_priority ctxt
>>=? fun block_priority ->
Baking.endorsing_reward ctxt ~block_priority gap
>>=? fun reward ->
Delegate.freeze_rewards ctxt delegate reward
>>=? fun ctxt ->
let level = Level.from_raw ctxt level in
return
( ctxt,
Single_result
(Endorsement_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ ( Contract (Contract.implicit_contract delegate),
Debited deposit );
(Deposits (delegate, level.cycle), Credited deposit);
(Rewards (delegate, level.cycle), Credited reward) ];
delegate;
slots;
}) )
| Single (Seed_nonce_revelation {level; nonce}) ->
let level = Level.from_raw ctxt level in
Nonce.reveal ctxt level nonce
>>=? fun ctxt ->
let seed_nonce_revelation_tip =
Constants.seed_nonce_revelation_tip ctxt
in
add_rewards ctxt seed_nonce_revelation_tip
>>=? fun ctxt ->
return
( ctxt,
Single_result
(Seed_nonce_revelation_result
[ ( Rewards (baker, level.cycle),
Credited seed_nonce_revelation_tip ) ]) )
| Single (Double_endorsement_evidence {op1; op2}) -> (
match (op1.protocol_data.contents, op2.protocol_data.contents) with
| (Single (Endorsement e1), Single (Endorsement e2))
when Raw_level.(e1.level = e2.level)
&& not (Block_hash.equal op1.shell.branch op2.shell.branch) ->
let level = Level.from_raw ctxt e1.level in
let oldest_level = Level.last_allowed_fork_level ctxt in
fail_unless
Level.(level < Level.current ctxt)
(Too_early_double_endorsement_evidence
{level = level.level; current = (Level.current ctxt).level})
>>=? fun () ->
fail_unless
Raw_level.(oldest_level <= level.level)
(Outdated_double_endorsement_evidence
{level = level.level; last = oldest_level})
>>=? fun () ->
Baking.check_endorsement_rights ctxt chain_id op1
>>=? fun (delegate1, _, _) ->
Baking.check_endorsement_rights ctxt chain_id op2
>>=? fun (delegate2, _, _) ->
fail_unless
(Signature.Public_key_hash.equal delegate1 delegate2)
(Inconsistent_double_endorsement_evidence {delegate1; delegate2})
>>=? fun () ->
Delegate.has_frozen_balance ctxt delegate1 level.cycle
>>=? fun valid ->
fail_unless valid Unrequired_double_endorsement_evidence
>>=? fun () ->
Delegate.punish ctxt delegate1 level.cycle
>>=? fun (ctxt, balance) ->
Lwt.return Tez.(balance.deposit +? balance.fees)
>>=? fun burned ->
let reward =
match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
in
add_rewards ctxt reward
>>=? fun ctxt ->
let current_cycle = (Level.current ctxt).cycle in
return
( ctxt,
Single_result
(Double_endorsement_evidence_result
(Delegate.cleanup_balance_updates
[ ( Deposits (delegate1, level.cycle),
Debited balance.deposit );
(Fees (delegate1, level.cycle), Debited balance.fees);
( Rewards (delegate1, level.cycle),
Debited balance.rewards );
(Rewards (baker, current_cycle), Credited reward) ])) )
| (_, _) ->
fail Invalid_double_endorsement_evidence )
| Single (Double_baking_evidence {bh1; bh2}) ->
let hash1 = Block_header.hash bh1 in
let hash2 = Block_header.hash bh2 in
fail_unless
( Compare.Int32.(bh1.shell.level = bh2.shell.level)
&& not (Block_hash.equal hash1 hash2) )
(Invalid_double_baking_evidence
{hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level})
>>=? fun () ->
Lwt.return (Raw_level.of_int32 bh1.shell.level)
>>=? fun raw_level ->
let oldest_level = Level.last_allowed_fork_level ctxt in
fail_unless
Raw_level.(raw_level < (Level.current ctxt).level)
(Too_early_double_baking_evidence
{level = raw_level; current = (Level.current ctxt).level})
>>=? fun () ->
fail_unless
Raw_level.(oldest_level <= raw_level)
(Outdated_double_baking_evidence
{level = raw_level; last = oldest_level})
>>=? fun () ->
let level = Level.from_raw ctxt raw_level in
Roll.baking_rights_owner
ctxt
level
~priority:bh1.protocol_data.contents.priority
>>=? fun delegate1 ->
Baking.check_signature bh1 chain_id delegate1
>>=? fun () ->
Roll.baking_rights_owner
ctxt
level
~priority:bh2.protocol_data.contents.priority
>>=? fun delegate2 ->
Baking.check_signature bh2 chain_id delegate2
>>=? fun () ->
fail_unless
(Signature.Public_key.equal delegate1 delegate2)
(Inconsistent_double_baking_evidence
{
delegate1 = Signature.Public_key.hash delegate1;
delegate2 = Signature.Public_key.hash delegate2;
})
>>=? fun () ->
let delegate = Signature.Public_key.hash delegate1 in
Delegate.has_frozen_balance ctxt delegate level.cycle
>>=? fun valid ->
fail_unless valid Unrequired_double_baking_evidence
>>=? fun () ->
Delegate.punish ctxt delegate level.cycle
>>=? fun (ctxt, balance) ->
Lwt.return Tez.(balance.deposit +? balance.fees)
>>=? fun burned ->
let reward =
match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
in
add_rewards ctxt reward
>>=? fun ctxt ->
let current_cycle = (Level.current ctxt).cycle in
return
( ctxt,
Single_result
(Double_baking_evidence_result
(Delegate.cleanup_balance_updates
[ (Deposits (delegate, level.cycle), Debited balance.deposit);
(Fees (delegate, level.cycle), Debited balance.fees);
(Rewards (delegate, level.cycle), Debited balance.rewards);
(Rewards (baker, current_cycle), Credited reward) ])) )
| Single (Activate_account {id = pkh; activation_code}) -> (
let blinded_pkh =
Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
in
Commitment.get_opt ctxt blinded_pkh
>>=? function
| None ->
fail (Invalid_activation {pkh})
| Some amount ->
Commitment.delete ctxt blinded_pkh
>>=? fun ctxt ->
let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
Contract.(credit ctxt contract amount)
>>=? fun ctxt ->
return
( ctxt,
Single_result
(Activate_account_result [(Contract contract, Credited amount)])
) )
| Single (Proposals {source; period; proposals}) ->
Roll.delegate_pubkey ctxt source
>>=? fun delegate ->
Operation.check_signature delegate chain_id operation
>>=? fun () ->
let level = Level.current ctxt in
fail_unless
Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period))
>>=? fun () ->
Amendment.record_proposals ctxt source proposals
>>=? fun ctxt -> return (ctxt, Single_result Proposals_result)
| Single (Ballot {source; period; proposal; ballot}) ->
Roll.delegate_pubkey ctxt source
>>=? fun delegate ->
Operation.check_signature delegate chain_id operation
>>=? fun () ->
let level = Level.current ctxt in
fail_unless
Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period))
>>=? fun () ->
Amendment.record_ballot ctxt source proposal ballot
>>=? fun ctxt -> return (ctxt, Single_result Ballot_result)
| Single (Manager_operation _) as op ->
precheck_manager_contents_list ctxt chain_id operation op
>>=? fun ctxt ->
apply_manager_contents_list ctxt mode baker chain_id op
>>= fun (ctxt, result) -> return (ctxt, result)
| Cons (Manager_operation _, _) as op ->
precheck_manager_contents_list ctxt chain_id operation op
>>=? fun ctxt ->
apply_manager_contents_list ctxt mode baker chain_id op
>>= fun (ctxt, result) -> return (ctxt, result)
let apply_operation ctxt chain_id mode pred_block baker hash operation =
let ctxt = Contract.init_origination_nonce ctxt hash in
apply_contents_list
ctxt
chain_id
mode
pred_block
baker
operation
operation.protocol_data.contents
>>=? fun (ctxt, result) ->
let ctxt = Gas.set_unlimited ctxt in
let ctxt = Contract.unset_origination_nonce ctxt in
return (ctxt, {contents = result})
let may_snapshot_roll ctxt =
let level = Alpha_context.Level.current ctxt in
let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in
if
Compare.Int32.equal
(Int32.rem level.cycle_position blocks_per_roll_snapshot)
(Int32.pred blocks_per_roll_snapshot)
then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt
else return ctxt
let may_start_new_cycle ctxt =
Baking.dawn_of_a_new_cycle ctxt
>>=? function
| None ->
return (ctxt, [], [])
| Some last_cycle ->
Seed.cycle_end ctxt last_cycle
>>=? fun (ctxt, unrevealed) ->
Roll.cycle_end ctxt last_cycle
>>=? fun ctxt ->
Delegate.cycle_end ctxt last_cycle unrevealed
>>=? fun (ctxt, update_balances, deactivated) ->
Bootstrap.cycle_end ctxt last_cycle
>>=? fun ctxt -> return (ctxt, update_balances, deactivated)
let begin_full_construction ctxt pred_timestamp protocol_data =
Alpha_context.Global.set_block_priority
ctxt
protocol_data.Block_header.priority
>>=? fun ctxt ->
Baking.check_baking_rights ctxt protocol_data pred_timestamp
>>=? fun (delegate_pk, block_delay) ->
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return (ctxt, protocol_data, delegate_pk, block_delay)
let begin_partial_construction ctxt =
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return ctxt
let begin_application ctxt chain_id block_header pred_timestamp =
Alpha_context.Global.set_block_priority
ctxt
block_header.Block_header.protocol_data.contents.priority
>>=? fun ctxt ->
let current_level = Alpha_context.Level.current ctxt in
Baking.check_proof_of_work_stamp ctxt block_header
>>=? fun () ->
Baking.check_fitness_gap ctxt block_header
>>=? fun () ->
Baking.check_baking_rights
ctxt
block_header.protocol_data.contents
pred_timestamp
>>=? fun (delegate_pk, block_delay) ->
Baking.check_signature block_header chain_id delegate_pk
>>=? fun () ->
let has_commitment =
match block_header.protocol_data.contents.seed_nonce_hash with
| None ->
false
| Some _ ->
true
in
fail_unless
Compare.Bool.(has_commitment = current_level.expected_commitment)
(Invalid_commitment {expected = current_level.expected_commitment})
>>=? fun () ->
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return (ctxt, delegate_pk, block_delay)
let check_minimum_endorsements ctxt protocol_data block_delay
included_endorsements =
let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
let timestamp = Timestamp.current ctxt in
fail_unless
Compare.Int.(included_endorsements >= minimum)
(Not_enough_endorsements_for_priority
{
required = minimum;
priority = protocol_data.Block_header.priority;
endorsements = included_endorsements;
timestamp;
})
let finalize_application ctxt protocol_data delegate ~block_delay =
let included_endorsements = included_endorsements ctxt in
check_minimum_endorsements
ctxt
protocol_data
block_delay
included_endorsements
>>=? fun () ->
let deposit = Constants.block_security_deposit ctxt in
add_deposit ctxt delegate deposit
>>=? fun ctxt ->
Baking.baking_reward
ctxt
~block_priority:protocol_data.priority
~included_endorsements
>>=? fun reward ->
add_rewards ctxt reward
>>=? fun ctxt ->
Signature.Public_key_hash.Map.fold
(fun delegate deposit ctxt ->
ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit)
(get_deposits ctxt)
(return ctxt)
>>=? fun ctxt ->
(* end of level (from this point nothing should fail) *)
let fees = Alpha_context.get_fees ctxt in
Delegate.freeze_fees ctxt delegate fees
>>=? fun ctxt ->
let rewards = Alpha_context.get_rewards ctxt in
Delegate.freeze_rewards ctxt delegate rewards
>>=? fun ctxt ->
( match protocol_data.Block_header.seed_nonce_hash with
| None ->
return ctxt
| Some nonce_hash ->
Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} )
>>=? fun ctxt ->
(* end of cycle *)
may_snapshot_roll ctxt
>>=? fun ctxt ->
may_start_new_cycle ctxt
>>=? fun (ctxt, balance_updates, deactivated) ->
Amendment.may_start_new_voting_period ctxt
>>=? fun ctxt ->
let cycle = (Level.current ctxt).cycle in
let balance_updates =
Delegate.(
cleanup_balance_updates
( [ (Contract (Contract.implicit_contract delegate), Debited deposit);
(Deposits (delegate, cycle), Credited deposit);
(Rewards (delegate, cycle), Credited reward) ]
@ balance_updates ))
in
let consumed_gas =
Z.sub
(Constants.hard_gas_limit_per_block ctxt)
(Alpha_context.Gas.block_level ctxt)
in
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let receipt =
Apply_results.
{
baker = delegate;
level = Level.current ctxt;
voting_period_kind;
nonce_hash = protocol_data.seed_nonce_hash;
consumed_gas;
deactivated;
balance_updates;
}
in
return (ctxt, receipt)