main.ml
(*****************************************************************************)
(* *)
(* 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 - Protocol Signature Instance *)
type block_header_data = Alpha_context.Block_header.protocol_data
type block_header = Alpha_context.Block_header.t = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
let block_header_data_encoding =
Alpha_context.Block_header.protocol_data_encoding
type block_header_metadata = Apply_results.block_metadata
let block_header_metadata_encoding = Apply_results.block_metadata_encoding
type operation_data = Alpha_context.packed_protocol_data =
| Operation_data :
'kind Alpha_context.Operation.protocol_data
-> operation_data
let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding
type operation_receipt = Apply_results.packed_operation_metadata =
| Operation_metadata :
'kind Apply_results.operation_metadata
-> operation_receipt
| No_operation_metadata : operation_receipt
let operation_receipt_encoding = Apply_results.operation_metadata_encoding
let operation_data_and_receipt_encoding =
Apply_results.operation_data_and_metadata_encoding
type operation = Alpha_context.packed_operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let acceptable_pass = Alpha_context.Operation.acceptable_pass
let max_block_length = Alpha_context.Block_header.max_header_length
let max_operation_data_length =
Alpha_context.Constants.max_operation_data_length
let validation_passes =
let open Alpha_context.Constants in
Updater.
[
(* 2048 endorsements *)
{max_size = 2048 * 2048; max_op = Some 2048};
(* 32k of voting operations *)
{max_size = 32 * 1024; max_op = None};
(* revelations, wallet activations and denunciations *)
{
max_size = max_anon_ops_per_block * 1024;
max_op = Some max_anon_ops_per_block;
};
(* 512kB *)
{max_size = 512 * 1024; max_op = None};
]
let rpc_services =
Alpha_services.register () ;
Services_registration.get_rpc_services ()
type validation_state = Validate.validation_state
type application_state = Apply.application_state
let init_allowed_consensus_operations ctxt ~endorsement_level
~preendorsement_level =
let open Lwt_result_syntax in
let open Alpha_context in
let* ctxt = Delegate.prepare_stake_distribution ctxt in
let* ctxt, allowed_endorsements, allowed_preendorsements =
if Level.(endorsement_level = preendorsement_level) then
let* ctxt, slots =
Baking.endorsing_rights_by_first_slot ctxt endorsement_level
in
let consensus_operations = slots in
return (ctxt, consensus_operations, consensus_operations)
else
let* ctxt, endorsements =
Baking.endorsing_rights_by_first_slot ctxt endorsement_level
in
let* ctxt, preendorsements =
Baking.endorsing_rights_by_first_slot ctxt preendorsement_level
in
return (ctxt, endorsements, preendorsements)
in
let ctxt =
Consensus.initialize_consensus_operation
ctxt
~allowed_endorsements
~allowed_preendorsements
in
return ctxt
(** Circumstances and relevant information for [begin_validation] and
[begin_application] below. *)
type mode =
| Application of block_header
| Partial_validation of block_header
| Construction of {
predecessor_hash : Block_hash.t;
timestamp : Time.t;
block_header_data : block_header_data;
}
| Partial_construction of {
predecessor_hash : Block_hash.t;
timestamp : Time.t;
}
let prepare_ctxt ctxt mode ~(predecessor : Block_header.shell_header) =
let open Lwt_result_syntax in
let open Alpha_context in
let level, timestamp =
match mode with
| Application block_header | Partial_validation block_header ->
(block_header.shell.level, block_header.shell.timestamp)
| Construction {timestamp; _} | Partial_construction {timestamp; _} ->
(Int32.succ predecessor.level, timestamp)
in
let* ctxt, migration_balance_updates, migration_operation_results =
prepare ctxt ~level ~predecessor_timestamp:predecessor.timestamp ~timestamp
in
let*? predecessor_raw_level = Raw_level.of_int32 predecessor.level in
let predecessor_level = Level.from_raw ctxt predecessor_raw_level in
(* During block (full or partial) application or full construction,
endorsements must be for [predecessor_level] and preendorsements,
if any, for the block's level. In the mempool (partial
construction), only consensus operations for [predecessor_level]
(that is, head's level) are allowed (except for grandparent
endorsements, which are handled differently). *)
let preendorsement_level =
match mode with
| Application _ | Partial_validation _ | Construction _ ->
Level.current ctxt
| Partial_construction _ -> predecessor_level
in
let* ctxt =
init_allowed_consensus_operations
ctxt
~endorsement_level:predecessor_level
~preendorsement_level
in
Dal_apply.initialisation ~level:predecessor_level ctxt >>=? fun ctxt ->
return
( ctxt,
migration_balance_updates,
migration_operation_results,
predecessor_level,
predecessor_raw_level )
let begin_validation ctxt chain_id mode ~predecessor =
let open Lwt_result_syntax in
let open Alpha_context in
let* ( ctxt,
_migration_balance_updates,
_migration_operation_results,
predecessor_level,
_predecessor_raw_level ) =
prepare_ctxt ctxt ~predecessor mode
in
let predecessor_timestamp = predecessor.timestamp in
let predecessor_fitness = predecessor.fitness in
match mode with
| Application block_header ->
let*? fitness = Fitness.from_raw block_header.shell.fitness in
Validate.begin_application
ctxt
chain_id
~predecessor_level
~predecessor_timestamp
block_header
fitness
| Partial_validation block_header ->
let*? fitness = Fitness.from_raw block_header.shell.fitness in
Validate.begin_partial_validation
ctxt
chain_id
~predecessor_level
~predecessor_timestamp
block_header
fitness
| Construction {predecessor_hash; timestamp; block_header_data} ->
let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in
let*? round =
Round.round_of_timestamp
(Constants.round_durations ctxt)
~predecessor_timestamp
~predecessor_round
~timestamp
in
Validate.begin_full_construction
ctxt
chain_id
~predecessor_level
~predecessor_round
~predecessor_timestamp
~predecessor_hash
round
block_header_data.contents
| Partial_construction _ ->
let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in
let*? grandparent_round =
Fitness.predecessor_round_from_raw predecessor_fitness
in
return
(Validate.begin_partial_construction
ctxt
chain_id
~predecessor_level
~predecessor_round
~grandparent_round)
let validate_operation = Validate.validate_operation
let finalize_validation = Validate.finalize_block
type error += Cannot_apply_in_partial_validation
let () =
register_error_kind
`Permanent
~id:"main.begin_application.cannot_apply_in_partial_validation"
~title:"cannot_apply_in_partial_validation"
~description:
"Cannot instantiate an application state using the 'Partial_validation' \
mode."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Cannot instantiate an application state using the \
'Partial_validation' mode.")
Data_encoding.(empty)
(function Cannot_apply_in_partial_validation -> Some () | _ -> None)
(fun () -> Cannot_apply_in_partial_validation)
let begin_application ctxt chain_id mode ~predecessor =
let open Lwt_result_syntax in
let open Alpha_context in
let* ( ctxt,
migration_balance_updates,
migration_operation_results,
predecessor_level,
predecessor_raw_level ) =
prepare_ctxt ctxt ~predecessor mode
in
let predecessor_timestamp = predecessor.timestamp in
let predecessor_fitness = predecessor.fitness in
match mode with
| Application block_header ->
Apply.begin_application
ctxt
chain_id
~migration_balance_updates
~migration_operation_results
~predecessor_fitness
block_header
| Partial_validation _ -> tzfail Cannot_apply_in_partial_validation
| Construction {predecessor_hash; timestamp; block_header_data; _} ->
let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in
Apply.begin_full_construction
ctxt
chain_id
~migration_balance_updates
~migration_operation_results
~predecessor_timestamp
~predecessor_level
~predecessor_round
~predecessor_hash
~timestamp
block_header_data.contents
| Partial_construction {predecessor_hash; _} ->
Apply.begin_partial_construction
ctxt
chain_id
~migration_balance_updates
~migration_operation_results
~predecessor_level:predecessor_raw_level
~predecessor_hash
~predecessor_fitness
let apply_operation = Apply.apply_operation
let finalize_application = Apply.finalize_block
let compare_operations (oph1, op1) (oph2, op2) =
Alpha_context.Operation.compare (oph1, op1) (oph2, op2)
let init chain_id ctxt block_header =
let level = block_header.Block_header.level in
let timestamp = block_header.timestamp in
let predecessor = block_header.predecessor in
let typecheck (ctxt : Alpha_context.context) (script : Alpha_context.Script.t)
=
let allow_forged_in_storage =
false
(* There should be no forged value in bootstrap contracts. *)
in
Script_ir_translator.parse_script
ctxt
~elab_conf:Script_ir_translator_config.(make ~legacy:true ())
~allow_forged_in_storage
script
>>=? fun (Ex_script (Script parsed_script), ctxt) ->
Script_ir_translator.extract_lazy_storage_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate:Script_ir_translator.no_lazy_storage_id
~to_update:Script_ir_translator.no_lazy_storage_id
~temporary:false
>>=? fun (storage, lazy_storage_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
parsed_script.storage_type
storage
>|=? fun (storage, ctxt) ->
let storage = Alpha_context.Script.lazy_expr storage in
(({script with storage}, lazy_storage_diff), ctxt)
in
(* The cache must be synced at the end of block validation, so we do
so here for the first block in a protocol where `finalize_block`
is not called. *)
Alpha_context.Raw_level.of_int32 level >>?= fun raw_level ->
let init_fitness =
Alpha_context.Fitness.create_without_locked_round
~level:raw_level
~round:Alpha_context.Round.zero
~predecessor_round:Alpha_context.Round.zero
in
Alpha_context.prepare_first_block
chain_id
~typecheck
~level
~timestamp
~predecessor
ctxt
>>=? fun ctxt ->
let cache_nonce =
Alpha_context.Cache.cache_nonce_from_block_header
block_header
({
payload_hash = Block_payload_hash.zero;
payload_round = Alpha_context.Round.zero;
liquidity_baking_toggle_vote = Alpha_context.Liquidity_baking.LB_pass;
seed_nonce_hash = None;
proof_of_work_nonce =
Bytes.make Constants_repr.proof_of_work_nonce_size '0';
}
: Alpha_context.Block_header.contents)
in
Alpha_context.Cache.Admin.sync ctxt cache_nonce >>= fun ctxt ->
return
(Alpha_context.finalize ctxt (Alpha_context.Fitness.to_raw init_fitness))
let value_of_key ~chain_id:_ ~predecessor_context:ctxt ~predecessor_timestamp
~predecessor_level:pred_level ~predecessor_fitness:_ ~predecessor:_
~timestamp =
let level = Int32.succ pred_level in
Alpha_context.prepare ctxt ~level ~predecessor_timestamp ~timestamp
>>=? fun (ctxt, _, _) -> return (Apply.value_of_key ctxt)
module Mempool = struct
include Mempool_validation
let init ctxt chain_id ~head_hash ~(head : Block_header.shell_header) =
let open Lwt_result_syntax in
let open Alpha_context in
let* ( ctxt,
_migration_balance_updates,
_migration_operation_results,
head_level,
_head_raw_level ) =
(* We use Partial_construction to factorize the [prepare_ctxt]. *)
prepare_ctxt
ctxt
(Partial_construction
{predecessor_hash = head_hash; timestamp = head.timestamp})
~predecessor:head
in
let*? predecessor_round = Fitness.round_from_raw head.fitness in
let*? grandparent_round = Fitness.predecessor_round_from_raw head.fitness in
return
(init
ctxt
chain_id
~predecessor_level:head_level
~predecessor_round
~predecessor_hash:head_hash
~grandparent_round)
end
(* Vanity nonce: 6455568396538124 *)
