ligo/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *)
open Alpha_context

(* This type collects a block and the context that results from its application *)
type t = {
  hash : Block_hash.t ;
  header : Block_header.t ;
  operations : Operation.packed list ;
  context : Tezos_protocol_environment.Context.t ;
}
type block = t

let rpc_context block = {
  Environment.Updater.block_hash = block.hash ;
  block_header = block.header.shell ;
  context = block.context ;
}

let rpc_ctxt =
  new Environment.proto_rpc_context_of_directory
    rpc_context rpc_services

(******** Policies ***********)

(* Policies are functions that take a block and return a tuple
   [(account, level, timestamp)] for the [forge_header] function. *)

(* This type is used only to provide a simpler interface to the exterior. *)
type baker_policy =
  | By_priority of int
  | By_account of public_key_hash
  | Excluding of public_key_hash list

let get_next_baker_by_priority priority block =
  Alpha_services.Delegate.Baking_rights.get rpc_ctxt
    ~all:true
    ~max_priority:(priority+1) block >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
        timestamp; _ } = List.find (fun { Alpha_services.Delegate.Baking_rights.priority = p ; _ } -> p = priority)  bakers in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_by_account pkh block =
  Alpha_services.Delegate.Baking_rights.get rpc_ctxt
    ~delegates:[pkh]
    ~max_priority:256 block >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
        timestamp ; priority ; _ } = List.hd bakers in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_excluding excludes block =
  Alpha_services.Delegate.Baking_rights.get rpc_ctxt
    ~max_priority:256 block >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
        timestamp ; priority ; _ } =
    List.find
      (fun { Alpha_services.Delegate.Baking_rights.delegate ; _ } ->
         not (List.mem delegate excludes))
      bakers in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let dispatch_policy = function
  | By_priority p -> get_next_baker_by_priority p
  | By_account a -> get_next_baker_by_account a
  | Excluding al -> get_next_baker_excluding al

let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy

let get_endorsing_power b =
  fold_left_s (fun acc (op: Operation.packed) ->
      let Operation_data data = op.protocol_data in
      match data.contents with
      | Single Endorsement _ ->
          Alpha_services.Delegate.Endorsing_power.get
            rpc_ctxt b op Chain_id.zero >>=? fun endorsement_power ->
          return (acc + endorsement_power)
      | _ -> return acc)
    0 b.operations

module Forge = struct

  type header = {
    baker : public_key_hash ;   (* the signer of the block *)
    shell : Block_header.shell_header ;
    contents : Block_header.contents ;
  }

  let default_proof_of_work_nonce =
    MBytes.create Constants.proof_of_work_nonce_size

  let make_contents
      ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ~priority ~seed_nonce_hash () =
    Block_header.{ priority ;
                   proof_of_work_nonce ;
                   seed_nonce_hash }

  let make_shell
      ~level ~predecessor ~timestamp ~fitness ~operations_hash =
    Tezos_base.Block_header.{
      level ;
      predecessor ;
      timestamp ;
      fitness ;
      operations_hash ;
      (* We don't care of the following values, only the shell validates them. *)
      proto_level = 0 ;
      validation_passes = 0 ;
      context = Context_hash.zero ;
    }

  let set_seed_nonce_hash seed_nonce_hash { baker ; shell ; contents } =
    { baker ; shell ; contents = { contents with seed_nonce_hash } }

  let set_baker baker header = { header with baker }

  let sign_header { baker ; shell ; contents } =
    Account.find baker >>=? fun delegate ->
    let unsigned_bytes =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents) in
    let signature =
      Signature.sign ~watermark:Signature.(Block_header Chain_id.zero) delegate.sk unsigned_bytes in
    Block_header.{ shell ; protocol_data = { contents ; signature } } |>
    return

  let forge_header
      ?(policy = By_priority 0)
      ?timestamp
      ?(operations = []) pred =
    dispatch_policy policy pred >>=? fun (pkh, priority, _timestamp) ->
    Alpha_services.Delegate.Minimal_valid_time.get
      rpc_ctxt pred priority 0 >>=? fun expected_timestamp ->
    let timestamp = Option.unopt ~default:expected_timestamp timestamp in
    let level = Int32.succ pred.header.shell.level in
    begin
      match Fitness_repr.to_int64 pred.header.shell.fitness with
      | Ok old_fitness ->
          return (Fitness_repr.from_int64
                    (Int64.add (Int64.of_int 1) old_fitness))
      | Error _ -> assert false
    end >>=? fun fitness ->
    begin
      Alpha_services.Helpers.current_level ~offset:1l (rpc_ctxt) pred >>|? function
      | { expected_commitment = true ; _ } -> Some (fst (Proto_Nonce.generate ()))
      | { expected_commitment = false ; _ } -> None
    end >>=? fun seed_nonce_hash ->
    let hashes = List.map Operation.hash_packed operations in
    let operations_hash = Operation_list_list_hash.compute
        [Operation_list_hash.compute hashes] in
    let shell = make_shell ~level ~predecessor:pred.hash
        ~timestamp ~fitness ~operations_hash in
    let contents = make_contents ~priority ~seed_nonce_hash () in
    return { baker = pkh ; shell ; contents }

  (* compatibility only, needed by incremental *)
  let contents
      ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ?(priority = 0) ?seed_nonce_hash () =
    {
      Block_header.priority ;
      proof_of_work_nonce ;
      seed_nonce_hash ;
    }

end

(********* Genesis creation *************)

(* Hard-coded context key *)
let protocol_param_key = [ "protocol_parameters" ]

let check_constants_consistency constants =
  let open Constants_repr in
  let { blocks_per_cycle ; blocks_per_commitment ;
        blocks_per_roll_snapshot ; _ } = constants in
  Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
    (fun () -> failwith "Inconsistent constants : blocks per commitment must be \
                         less than blocks per cycle") >>=? fun () ->
  Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
    (fun () -> failwith "Inconsistent constants : blocks per cycle \
                         must be superior than blocks per roll snapshot") >>=?
  return

let initial_context
    ?(with_commitments = false)
    constants
    header
    initial_accounts
  =
  let open Tezos_protocol_005_PsBabyM1_parameters in
  let bootstrap_accounts =
    List.map (fun (Account.{ pk ; pkh ; _ }, amount) ->
        Default_parameters.make_bootstrap_account (pkh, pk, amount)
      ) initial_accounts
  in

  let parameters =
    Default_parameters.parameters_of_constants
      ~bootstrap_accounts
      ~with_commitments
      constants in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt ->
    set ctxt protocol_param_key proto_params
  ) >>= fun ctxt ->
  Main.init ctxt header
  >|= Environment.wrap_error >>=? fun { context; _ } ->
  return context

let genesis_with_parameters parameters =
  let hash =
    Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell = Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness: (Fitness_repr.from_int64 0L)
      ~operations_hash: Operation_list_list_hash.zero in
  let contents = Forge.make_contents
      ~priority:0
      ~seed_nonce_hash:None () in
  let open Tezos_protocol_005_PsBabyM1_parameters in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt ->
    set ctxt protocol_param_key proto_params
  ) >>= fun ctxt ->
  Main.init ctxt shell
  >|= Environment.wrap_error >>=? fun { context; _ } ->
  let block = { hash ;
                header = { shell ;
                           protocol_data = {
                             contents = contents ;
                             signature = Signature.zero ;
                           } } ;
                operations = [] ;
                context ;
              } in
  return block

(* if no parameter file is passed we check in the current directory
   where the test is run *)
let genesis
    ?with_commitments
    ?endorsers_per_block
    ?initial_endorsers
    ?min_proposal_quorum
    (initial_accounts : (Account.t * Tez_repr.t) list)
  =
  if initial_accounts = [] then
    Pervasives.failwith "Must have one account with a roll to bake";

  let open Tezos_protocol_005_PsBabyM1_parameters in
  let constants = Default_parameters.constants_test in
  let endorsers_per_block =
    Option.unopt ~default:constants.endorsers_per_block endorsers_per_block in
  let initial_endorsers =
    Option.unopt ~default:constants.initial_endorsers initial_endorsers in
  let min_proposal_quorum =
    Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum in
  let constants = { constants with endorsers_per_block ; initial_endorsers ; min_proposal_quorum } in

  (* Check there is at least one roll *)
  begin try
      let open Test_utils in
      fold_left_s (fun acc (_, amount) ->
          Environment.wrap_error @@
          Tez_repr.(+?) acc amount >>?= fun acc ->
          if acc >= constants.tokens_per_roll then
            raise Exit
          else return acc
        ) Tez_repr.zero initial_accounts >>=? fun _ ->
      failwith "Insufficient tokens in initial accounts to create one roll"
    with Exit -> return_unit
  end >>=? fun () ->

  check_constants_consistency constants >>=? fun () ->

  let hash =
    Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell = Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness: (Fitness_repr.from_int64 0L)
      ~operations_hash: Operation_list_list_hash.zero in
  let contents = Forge.make_contents
      ~priority:0
      ~seed_nonce_hash:None () in
  initial_context
    ?with_commitments
    constants
    shell
    initial_accounts
  >>=? fun context ->
  let block =
    { hash ;
      header = {
        shell = shell ;
        protocol_data = {
          contents = contents ;
          signature = Signature.zero ;
        } ;
      };
      operations = [] ;
      context ;
    }
  in
  return block

(********* Baking *************)

let apply header ?(operations = []) pred =
  begin
    let open Environment.Error_monad in
    Main.begin_application
      ~chain_id: Chain_id.zero
      ~predecessor_context: pred.context
      ~predecessor_fitness: pred.header.shell.fitness
      ~predecessor_timestamp: pred.header.shell.timestamp
      header >>=? fun vstate ->
    fold_left_s
      (fun vstate op ->
         apply_operation vstate op >>=? fun (state, _result) ->
         return state)
      vstate operations >>=? fun vstate ->
    Main.finalize_block vstate >>=? fun (validation, _result) ->
    return validation.context
  end >|= Environment.wrap_error >>|? fun context ->
  let hash = Block_header.hash header in
  { hash ; header ; operations ; context }

let bake ?policy ?timestamp ?operation ?operations pred =
  let operations =
    match operation,operations with
    | Some op, Some ops -> Some (op::ops)
    | Some op, None -> Some [op]
    | None, Some ops -> Some ops
    | None, None -> None
  in
  Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header ->
  Forge.sign_header header >>=? fun header ->
  apply header ?operations pred

(********** Cycles ****************)

(* This function is duplicated from Context to avoid a cyclic dependency *)
let get_constants b =
  Alpha_services.Constants.all rpc_ctxt b

let bake_n ?policy n b =
  Error_monad.fold_left_s
    (fun b _ -> bake ?policy b) b (1 -- n)

let bake_until_cycle_end ?policy b =
  get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } ->
  let current_level = b.header.shell.level in
  let current_level = Int32.rem current_level blocks_per_cycle in
  let delta = Int32.sub blocks_per_cycle current_level in
  bake_n ?policy (Int32.to_int delta) b

let bake_until_n_cycle_end ?policy n b =
  Error_monad.fold_left_s
    (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n)

let bake_until_cycle ?policy cycle (b:t) =
  get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } ->
  let rec loop (b:t) =
    let current_cycle =
      let current_level = b.header.shell.level in
      let current_cycle = Int32.div current_level blocks_per_cycle in
      current_cycle
    in
    if Int32.equal (Cycle.to_int32 cycle) current_cycle then
      return b
    else
      bake_until_cycle_end ?policy b >>=? fun b ->
      loop b
  in
  loop b