Source file 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 *)

open Misc.Syntax

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_passes = Alpha_context.Operation.acceptable_passes

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.
    [ (* 32 endorsements *)
      {max_size = 32 * 1024; max_op = Some 32};
      (* 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_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context

let begin_partial_application ~chain_id ~ancestor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >|=? fun (ctxt, baker, block_delay) ->
  let mode =
    Partial_application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  {mode; chain_id; ctxt; op_count = 0}

let begin_application ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >|=? fun (ctxt, baker, block_delay) ->
  let mode =
    Application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  {mode; chain_id; ctxt; op_count = 0}

let begin_construction ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_level:pred_level
    ~predecessor_fitness:pred_fitness ~predecessor ~timestamp
    ?(protocol_data : block_header_data option) () =
  let level = Int32.succ pred_level in
  let fitness = pred_fitness in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  ( match protocol_data with
  | None ->
      Apply.begin_partial_construction ctxt
      >|=? fun ctxt ->
      let mode = Partial_construction {predecessor} in
      (mode, ctxt)
  | Some proto_header ->
      Apply.begin_full_construction
        ctxt
        predecessor_timestamp
        proto_header.contents
      >|=? fun (ctxt, protocol_data, baker, block_delay) ->
      let mode =
        let baker = Signature.Public_key.hash baker in
        Full_construction {predecessor; baker; protocol_data; block_delay}
      in
      (mode, ctxt) )
  >|=? fun (mode, ctxt) -> {mode; chain_id; ctxt; op_count = 0}

let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
    (operation : Alpha_context.packed_operation) =
  match mode with
  | Partial_application _
    when not
           (List.exists
              (Compare.Int.equal 0)
              (Alpha_context.Operation.acceptable_passes operation)) ->
      (* Multipass validation only considers operations in pass 0. *)
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, No_operation_metadata)
  | _ ->
      let {shell; protocol_data = Operation_data protocol_data} = operation in
      let operation : _ Alpha_context.operation = {shell; protocol_data} in
      let (predecessor, baker) =
        match mode with
        | Partial_application
            {block_header = {shell = {predecessor; _}; _}; baker}
        | Application {block_header = {shell = {predecessor; _}; _}; baker}
        | Full_construction {predecessor; baker; _} ->
            (predecessor, baker)
        | Partial_construction {predecessor} ->
            (predecessor, Signature.Public_key_hash.zero)
      in
      Apply.apply_operation
        ctxt
        chain_id
        Optimized
        predecessor
        baker
        (Alpha_context.Operation.hash operation)
        operation
      >|=? fun (ctxt, result) ->
      let op_count = op_count + 1 in
      ({data with ctxt; op_count}, Operation_metadata result)

let finalize_block {mode; ctxt; op_count} =
  match mode with
  | Partial_construction _ ->
      let level = Alpha_context.Level.current ctxt in
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let baker = Signature.Public_key_hash.zero in
      Signature.Public_key_hash.Map.fold
        (fun delegate deposit ctxt ->
          ctxt
          >>=? fun ctxt ->
          Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
        (Alpha_context.get_deposits ctxt)
        (return ctxt)
      >|=? fun ctxt ->
      let ctxt = Alpha_context.finalize ctxt in
      ( ctxt,
        Apply_results.
          {
            baker;
            level;
            voting_period_kind;
            nonce_hash = None;
            consumed_gas = Alpha_context.Gas.Arith.zero;
            deactivated = [];
            balance_updates = [];
          } )
  | Partial_application {block_header; baker; block_delay} ->
      let level = Alpha_context.Level.current ctxt in
      let included_endorsements = Alpha_context.included_endorsements ctxt in
      Apply.check_minimum_endorsements
        ctxt
        block_header.protocol_data.contents
        block_delay
        included_endorsements
      >>?= fun () ->
      Alpha_context.Vote.get_current_period_kind ctxt
      >|=? fun voting_period_kind ->
      let ctxt = Alpha_context.finalize ctxt in
      ( ctxt,
        Apply_results.
          {
            baker;
            level;
            voting_period_kind;
            nonce_hash = None;
            consumed_gas = Alpha_context.Gas.Arith.zero;
            deactivated = [];
            balance_updates = [];
          } )
  | Application
      { baker;
        block_delay;
        block_header = {protocol_data = {contents = protocol_data; _}; _} }
  | Full_construction {protocol_data; baker; block_delay; _} ->
      Apply.finalize_application ctxt protocol_data baker ~block_delay
      >|=? fun (ctxt, receipt) ->
      let level = Alpha_context.Level.current ctxt in
      let priority = protocol_data.priority in
      let raw_level = Alpha_context.Raw_level.to_int32 level.level in
      let fitness = Alpha_context.Fitness.current ctxt in
      let commit_message =
        Format.asprintf
          "lvl %ld, fit 1:%Ld, prio %d, %d ops"
          raw_level
          fitness
          priority
          op_count
      in
      let ctxt = Alpha_context.finalize ~commit_message ctxt in
      (ctxt, receipt)

let compare_operations op1 op2 =
  let open Alpha_context in
  let (Operation_data op1) = op1.protocol_data in
  let (Operation_data op2) = op2.protocol_data in
  match (op1.contents, op2.contents) with
  | (Single (Endorsement _), Single (Endorsement _)) ->
      0
  | (_, Single (Endorsement _)) ->
      1
  | (Single (Endorsement _), _) ->
      -1
  | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
      0
  | (_, Single (Seed_nonce_revelation _)) ->
      1
  | (Single (Seed_nonce_revelation _), _) ->
      -1
  | ( Single (Double_endorsement_evidence _),
      Single (Double_endorsement_evidence _) ) ->
      0
  | (_, Single (Double_endorsement_evidence _)) ->
      1
  | (Single (Double_endorsement_evidence _), _) ->
      -1
  | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
      0
  | (_, Single (Double_baking_evidence _)) ->
      1
  | (Single (Double_baking_evidence _), _) ->
      -1
  | (Single (Activate_account _), Single (Activate_account _)) ->
      0
  | (_, Single (Activate_account _)) ->
      1
  | (Single (Activate_account _), _) ->
      -1
  | (Single (Proposals _), Single (Proposals _)) ->
      0
  | (_, Single (Proposals _)) ->
      1
  | (Single (Proposals _), _) ->
      -1
  | (Single (Ballot _), Single (Ballot _)) ->
      0
  | (_, Single (Ballot _)) ->
      1
  | (Single (Ballot _), _) ->
      -1
  (* Manager operations with smaller counter are pre-validated first. *)
  | (Single (Manager_operation op1), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter

let init ctxt block_header =
  let level = block_header.Block_header.level in
  let fitness = block_header.fitness in
  let timestamp = block_header.timestamp in
  let typecheck (ctxt : Alpha_context.context)
      (script : Alpha_context.Script.t) =
    Script_ir_translator.parse_script ctxt ~legacy:false script
    >>=? fun (Ex_script parsed_script, ctxt) ->
    Script_ir_translator.extract_big_map_diff
      ctxt
      Optimized
      parsed_script.storage_type
      parsed_script.storage
      ~to_duplicate:Script_ir_translator.no_big_map_id
      ~to_update:Script_ir_translator.no_big_map_id
      ~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 =
      Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
    in
    (({script with storage}, big_map_diff), ctxt)
  in
  Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
  >|=? fun ctxt -> Alpha_context.finalize ctxt

(* Vanity nonce: 1000005472341027 *)