diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 1c07bb08ee72db8f897d416054164e383f64cb1e..d47b0369d0d3a1ea2e69720b86948463736299a9 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -5626,7 +5626,7 @@ end = struct ~with_macos_security_framework:true ~deps: [ - alcotezt |> if_ N.(number <= 019); + alcotezt |> if_ N.(number <= 018); octez_base |> open_ ~m:"TzPervasives" |> error_monad_module N.(number <= 018); main |> open_; @@ -5645,15 +5645,14 @@ end = struct ("test_constants", true); ("test_frozen_bonds", true); ("test_adaptive_issuance_launch", N.(number >= 018)); - ( "test_adaptive_issuance_roundtrip", - N.(number == 018 || number == 019) ); - ("test_scenario_base", N.(number >= 020)); - ("test_scenario_stake", N.(number >= 020)); - ("test_scenario_rewards", N.(number >= 020)); - ("test_scenario_autostaking", N.(number >= 020)); - ("test_scenario_slashing", N.(number >= 020)); - ("test_scenario_slashing_stakers", N.(number >= 020)); - ("test_scenario_deactivation", N.(number >= 020)); + ("test_adaptive_issuance_roundtrip", N.(number == 018)); + ("test_scenario_base", N.(number >= 019)); + ("test_scenario_stake", N.(number >= 019)); + ("test_scenario_rewards", N.(number >= 019)); + ("test_scenario_autostaking", N.(number >= 019)); + ("test_scenario_slashing", N.(number >= 019)); + ("test_scenario_slashing_stakers", N.(number >= 019)); + ("test_scenario_deactivation", N.(number >= 019)); ("test_liquidity_baking", true); ("test_storage_functions", true); ("test_storage", true); @@ -5669,7 +5668,7 @@ end = struct ~deps: [ (if N.(number >= 015) then Some tezt_lib else None) |> if_some; - alcotezt |> if_ N.(number <= 019); + alcotezt |> if_ N.(number <= 018); octez_base |> open_ ~m:"TzPervasives" |> error_monad_module N.(number <= 018); client |> if_some |> open_; @@ -5774,8 +5773,8 @@ end = struct ("test_adaptive_issuance", N.(number >= 018)); ("test_adaptive_issuance_ema", N.(number >= 018)); ("test_percentage", N.(number >= 019)); - ("test_full_staking_balance_repr", N.(number >= 020)); - ("test_slashing_percentage", N.(number >= 020)); + ("test_full_staking_balance_repr", N.(number >= 019)); + ("test_slashing_percentage", N.(number >= 019)); ] |> conditional_list in @@ -6432,10 +6431,8 @@ let hash = Protocol.hash ~deps: [ tezt_core_lib |> if_ N.(number >= 019) |> open_ |> open_ ~m:"Base"; - alcotezt |> if_ N.(number == 019); - tezt_tezos |> if_ N.(number >= 020); + tezt_tezos |> if_ N.(number >= 019); tezt_lib |> if_ N.(number >= 019); - octez_base_test_helpers |> if_ N.(number == 019) |> open_; qcheck_alcotest; octez_test_helpers; octez_base |> open_ ~m:"TzPervasives" diff --git a/opam/octez-protocol-019-PtParisB-libs.opam b/opam/octez-protocol-019-PtParisB-libs.opam index e8b020715d401c94bc6ccf80ac6d22bfaa08004d..4e60e55be9827a992176a222bb51074f3f2f3184 100644 --- a/opam/octez-protocol-019-PtParisB-libs.opam +++ b/opam/octez-protocol-019-PtParisB-libs.opam @@ -16,7 +16,7 @@ depends: [ "octez-shell-libs" { = version } "uri" { >= "3.1.0" } "tezt" { >= "4.1.0" & < "5.0.0" } - "octez-alcotezt" { = version } + "tezt-tezos" { = version } "qcheck-alcotest" { >= "0.20" } "octez-proto-libs" { = version } "octez-version" { = version } @@ -29,6 +29,7 @@ depends: [ "tezos-dac-client-lib" { = version } "octez-injector" { = version } "octez-l2-libs" { = version } + "octez-alcotezt" { with-test & = version } "tezos-dac-node-lib" { with-test & = version } ] build: [ diff --git a/opam/tezos-protocol-019-PtParisB-tests.opam b/opam/tezos-protocol-019-PtParisB-tests.opam index 816606d005254ea52eb4dd2d2ba8c3d565afc2d0..bcbabddee90d21cca215285e0dd02ae937662256 100644 --- a/opam/tezos-protocol-019-PtParisB-tests.opam +++ b/opam/tezos-protocol-019-PtParisB-tests.opam @@ -11,10 +11,10 @@ depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } "tezt" { with-test & >= "4.1.0" & < "5.0.0" } - "octez-alcotezt" {with-test} "octez-libs" {with-test} "octez-protocol-019-PtParisB-libs" {with-test} "tezos-protocol-019-PtParisB" {with-test} + "octez-alcotezt" {with-test} "tezos-benchmark" {with-test} "tezos-benchmark-019-PtParisB" {with-test} "tezos-benchmark-type-inference-019-PtParisB" {with-test} diff --git a/src/proto_019_PtParisB/lib_plugin/RPC.ml b/src/proto_019_PtParisB/lib_plugin/RPC.ml index 402c8cdf2a4c778a39248ead267f6126bceb454b..54b63db5443686bd901f38c69db4587a8d863132 100644 --- a/src/proto_019_PtParisB/lib_plugin/RPC.ml +++ b/src/proto_019_PtParisB/lib_plugin/RPC.ml @@ -4439,6 +4439,9 @@ module Staking = struct let stakers ctxt block pkh = RPC_context.make_call1 S.stakers ctxt block pkh () () + + let is_forbidden ctxt block pkh = + RPC_context.make_call1 S.is_forbidden ctxt block pkh () () end module S = struct diff --git a/src/proto_019_PtParisB/lib_protocol/test/README.md b/src/proto_019_PtParisB/lib_protocol/test/README.md index d938f4e7cb3d358c45acdfb6635c3528fefd7403..6e7e33a67ec084fb7465114b95fe32f53bb28887 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/README.md +++ b/src/proto_019_PtParisB/lib_protocol/test/README.md @@ -24,7 +24,7 @@ create a new sub-folder corresponding to the theme of the test. To run all the tests, run: ``` -dune runtest src/proto_alpha/lib_protocol/ +dune runtest src/proto_019_PtParisB/lib_protocol/ ``` To run an individual test file, consult its `Invocation` header. diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/account_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/account_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..2378e47d532213cce1135570428b1596a904bbca --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/account_helpers.ml @@ -0,0 +1,546 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** [Account_helpers] defines a type abstracting the information of an account + in the protocol. This includes its pkh, delegate, any funds, staking + parameters, etc... + + A type [balance] is also defined, as an observed state of funds for a + given account, i.e balance information that one might get from calling + RPCs. *) + +open Adaptive_issuance_helpers +open Tez_staking_helpers + +let fail_account_not_found func_name account_name = + Log.error "State_account.%s: account %s not found" func_name account_name ; + assert false + +module CycleMap = Map.Make (Cycle) + +(** Abstract information of accounts *) +type account_state = { + pkh : Signature.Public_key_hash.t; + contract : Protocol.Alpha_context.Contract.t; + delegate : string option; + parameters : staking_parameters; + liquid : Tez.t; + bonds : Tez.t; + (* The three following fields contain maps from the account's stakers to, + respectively, their frozen stake, their unstaked frozen balance, and + their unstaked finalizable funds. Additionally, [unstaked_frozen] indexes + the maps with the cycle at which the unstake operation occurred. *) + frozen_deposits : Frozen_tez.t; + unstaked_frozen : Unstaked_frozen.t; + unstaked_finalizable : Unstaked_finalizable.t; + staking_delegator_numerator : Z.t; + staking_delegate_denominator : Z.t; + frozen_rights : Tez.t CycleMap.t; + (** The portion of rights that comes from staking, used for + baking/attesting during the specified cycle. + + At the end of cycle [c], the current frozen deposits of the + delegate (own + co-staked, taking + limit_of_staking_over_baking into account) are added to this + table for cycle [c + consensus_rights_delay + 1]. The table + is unmodified if at that time, the account is not a delegate + or is a deactivated delegate. *) + slashed_cycles : Cycle.t list; + last_active_cycle : Cycle.t; +} + +let init_account ?delegate ~pkh ~contract ~parameters ?(liquid = Tez.zero) + ?(bonds = Tez.zero) ?(frozen_deposits = Frozen_tez.zero) + ?(unstaked_frozen = Unstaked_frozen.zero) + ?(unstaked_finalizable = Unstaked_finalizable.zero) + ?(staking_delegator_numerator = Z.zero) + ?(staking_delegate_denominator = Z.zero) ?(frozen_rights = CycleMap.empty) + ?(slashed_cycles = []) ?(last_active_cycle = Cycle.root) () = + { + pkh; + contract; + delegate; + parameters; + liquid; + bonds; + frozen_deposits; + unstaked_frozen; + unstaked_finalizable; + staking_delegator_numerator; + staking_delegate_denominator; + frozen_rights; + slashed_cycles; + last_active_cycle; + } + +type account_map = account_state String.Map.t + +(** Balance returned by RPCs. Partial tez are rounded down *) +type balance = { + liquid_b : Tez.t; + bonds_b : Tez.t; + staked_b : Partial_tez.t; + unstaked_frozen_b : Tez.t; + unstaked_finalizable_b : Tez.t; + staking_delegator_numerator_b : Z.t; + staking_delegate_denominator_b : Z.t; +} + +let balance_zero = + { + liquid_b = Tez.zero; + bonds_b = Tez.zero; + staked_b = Partial_tez.zero; + unstaked_frozen_b = Tez.zero; + unstaked_finalizable_b = Tez.zero; + staking_delegator_numerator_b = Z.zero; + staking_delegate_denominator_b = Z.zero; + } + +let balance_of_account account_name (account_map : account_map) = + match String.Map.find account_name account_map with + | None -> fail_account_not_found "balance_of_account.src" account_name + | Some + { + pkh = _; + contract = _; + delegate; + parameters = _; + liquid; + bonds; + frozen_deposits = _; + unstaked_frozen = _; + unstaked_finalizable = _; + staking_delegator_numerator; + staking_delegate_denominator; + frozen_rights = _; + slashed_cycles = _; + last_active_cycle = _; + } -> + let balance = + { + balance_zero with + liquid_b = liquid; + bonds_b = bonds; + staking_delegator_numerator_b = staking_delegator_numerator; + staking_delegate_denominator_b = staking_delegate_denominator; + } + in + let balance = + match delegate with + | None -> balance + | Some d -> ( + match String.Map.find d account_map with + | None -> fail_account_not_found "balance_of_account.delegate" d + | Some delegate_account -> + { + balance with + staked_b = + Frozen_tez.get account_name delegate_account.frozen_deposits; + }) + in + (* Because an account can still have frozen or finalizable funds from a delegate + that is not its own, we iterate over all of them *) + let unstaked_frozen_b, unstaked_finalizable_b = + String.Map.fold + (fun _delegate_name delegate (frozen, finalzbl) -> + let frozen = + Tez.( + frozen + +! Unstaked_frozen.get_total + account_name + delegate.unstaked_frozen) + in + let finalzbl = + Tez.( + finalzbl + +! Unstaked_finalizable.get + account_name + delegate.unstaked_finalizable) + in + (frozen, finalzbl)) + account_map + (Tez.zero, Tez.zero) + in + {balance with unstaked_frozen_b; unstaked_finalizable_b} + +let balance_pp fmt + { + liquid_b; + bonds_b; + staked_b; + unstaked_frozen_b; + unstaked_finalizable_b; + staking_delegator_numerator_b; + staking_delegate_denominator_b; + } = + Format.fprintf + fmt + "{@;\ + @[ liquid : %a@;\ + bonds : %a@;\ + staked : %a@;\ + unstaked_frozen : %a@;\ + unstaked_finalizable : %a@;\ + staking_delegator_numerator : %a@;\ + staking_delegate_denominator : %a@;\ + }@." + Tez.pp + liquid_b + Tez.pp + bonds_b + Partial_tez.pp + staked_b + Tez.pp + unstaked_frozen_b + Tez.pp + unstaked_finalizable_b + Z.pp_print + staking_delegator_numerator_b + Z.pp_print + staking_delegate_denominator_b + +let balance_update_pp fmt + ( { + liquid_b = a_liquid_b; + bonds_b = a_bonds_b; + staked_b = a_staked_b; + unstaked_frozen_b = a_unstaked_frozen_b; + unstaked_finalizable_b = a_unstaked_finalizable_b; + staking_delegator_numerator_b = a_staking_delegator_numerator_b; + staking_delegate_denominator_b = a_staking_delegate_denominator_b; + }, + { + liquid_b = b_liquid_b; + bonds_b = b_bonds_b; + staked_b = b_staked_b; + unstaked_frozen_b = b_unstaked_frozen_b; + unstaked_finalizable_b = b_unstaked_finalizable_b; + staking_delegator_numerator_b = b_staking_delegator_numerator_b; + staking_delegate_denominator_b = b_staking_delegate_denominator_b; + } ) = + Format.fprintf + fmt + "{@;\ + @[ liquid : %a -> %a@;\ + bonds : %a -> %a@;\ + staked : %a -> %a@;\ + unstaked_frozen : %a -> %a@;\ + unstaked_finalizable : %a -> %a@;\ + staking_delegator_numerator : %a -> %a@;\ + staking_delegate_denominator : %a -> %a@;\ + }@." + Tez.pp + a_liquid_b + Tez.pp + b_liquid_b + Tez.pp + a_bonds_b + Tez.pp + b_bonds_b + Partial_tez.pp + a_staked_b + Partial_tez.pp + b_staked_b + Tez.pp + a_unstaked_frozen_b + Tez.pp + b_unstaked_frozen_b + Tez.pp + a_unstaked_finalizable_b + Tez.pp + b_unstaked_finalizable_b + Z.pp_print + a_staking_delegator_numerator_b + Z.pp_print + b_staking_delegator_numerator_b + Z.pp_print + a_staking_delegate_denominator_b + Z.pp_print + b_staking_delegate_denominator_b + +let assert_balance_equal ~loc account_name + { + liquid_b = a_liquid_b; + bonds_b = a_bonds_b; + staked_b = a_staked_b; + unstaked_frozen_b = a_unstaked_frozen_b; + unstaked_finalizable_b = a_unstaked_finalizable_b; + staking_delegator_numerator_b = a_staking_delegator_numerator_b; + staking_delegate_denominator_b = a_staking_delegate_denominator_b; + } + { + liquid_b = b_liquid_b; + bonds_b = b_bonds_b; + staked_b = b_staked_b; + unstaked_frozen_b = b_unstaked_frozen_b; + unstaked_finalizable_b = b_unstaked_finalizable_b; + staking_delegator_numerator_b = b_staking_delegator_numerator_b; + staking_delegate_denominator_b = b_staking_delegate_denominator_b; + } = + let open Lwt_result_syntax in + let f s = Format.asprintf "%s: %s" account_name s in + let* () = + List.fold_left + (fun a b -> + let*! a in + let*! b in + Assert.join_errors a b) + return_unit + [ + Assert.equal + ~loc + Tez.equal + (f "Liquid balances do not match") + Tez.pp + a_liquid_b + b_liquid_b; + Assert.equal + ~loc + Tez.equal + (f "Bonds balances do not match") + Tez.pp + a_bonds_b + b_bonds_b; + Assert.equal + ~loc + Tez.equal + (f "Staked balances do not match") + Tez.pp + (Partial_tez.to_tez ~round:`Down a_staked_b) + (Partial_tez.to_tez ~round:`Down b_staked_b); + Assert.equal + ~loc + Tez.equal + (f "Unstaked frozen balances do not match") + Tez.pp + a_unstaked_frozen_b + b_unstaked_frozen_b; + Assert.equal + ~loc + Tez.equal + (f "Unstaked finalizable balances do not match") + Tez.pp + a_unstaked_finalizable_b + b_unstaked_finalizable_b; + Assert.equal + ~loc + Z.equal + (f "Staking delegator numerators do not match") + Z.pp_print + a_staking_delegator_numerator_b + b_staking_delegator_numerator_b; + Assert.equal + ~loc + Z.equal + (f "Staking delegate denominators do not match") + Z.pp_print + a_staking_delegate_denominator_b + b_staking_delegate_denominator_b; + ] + in + return_unit + +let update_account ~f account_name account_map = + String.Map.update + account_name + (function + | None -> fail_account_not_found "update_account" account_name + | Some x -> Some (f x)) + account_map + +let balance_and_total_balance_of_account account_name account_map = + let ({ + liquid_b; + bonds_b; + staked_b; + unstaked_frozen_b; + unstaked_finalizable_b; + staking_delegator_numerator_b = _; + staking_delegate_denominator_b = _; + } as balance) = + balance_of_account account_name account_map + in + ( balance, + Tez.( + liquid_b +! bonds_b + +! Partial_tez.to_tez ~round:`Down staked_b + +! unstaked_frozen_b +! unstaked_finalizable_b) ) + +let assert_pseudotokens_consistency ~loc balance account account_name + account_map = + let open Lwt_result_syntax in + let {delegate; staking_delegator_numerator = num_pt; _} = account in + let exact_staking_balance = balance.staked_b in + match delegate with + | None -> return_unit + | Some delegate_name -> ( + if account_name = delegate_name then return_unit + else + match String.Map.find delegate_name account_map with + | None -> + fail_account_not_found + "assert_pseudotokens_consistency" + delegate_name + | Some delegate_account -> + let total_co = + Frozen_tez.total_co_current_q + delegate_account.frozen_deposits.co_current + in + let den_pt = delegate_account.staking_delegate_denominator in + if Z.(equal den_pt zero) then + Assert.equal + ~loc + Q.equal + (Format.asprintf + "%s : Delegate should not have external stake with a 0 \ + staking denominator" + account_name) + Q.pp_print + total_co + Q.zero + else + let expected = Q.(num_pt /// den_pt * total_co) in + Assert.equal + ~loc + Q.equal + (Format.asprintf + "%s : Pseudotokens do not match exact staking balance" + account_name) + Q.pp_print + exact_staking_balance + expected) + +let get_balance_from_context ctxt contract = + let open Lwt_result_syntax in + let* liquid_b = Context.Contract.balance ctxt contract in + let* bonds_b = Context.Contract.frozen_bonds ctxt contract in + let* staked_b = Context.Contract.staked_balance ctxt contract in + let staked_b = + Option.value ~default:Tez.zero staked_b |> Partial_tez.of_tez + in + let* unstaked_frozen_b = + Context.Contract.unstaked_frozen_balance ctxt contract + in + let unstaked_frozen_b = Option.value ~default:Tez.zero unstaked_frozen_b in + let* unstaked_finalizable_b = + Context.Contract.unstaked_finalizable_balance ctxt contract + in + let unstaked_finalizable_b = + Option.value ~default:Tez.zero unstaked_finalizable_b + in + let* total_balance = Context.Contract.full_balance ctxt contract in + let* staking_delegator_numerator_b = + Context.Contract.staking_numerator ctxt contract + in + let*! staking_delegate_denominator_b = + match (contract : Protocol.Alpha_context.Contract.t) with + | Implicit pkh -> + let*! result = Context.Delegate.staking_denominator ctxt pkh in + Lwt.return + (match result with + | Ok v -> v + | Error _ -> (* Not a delegate *) Z.zero) + | Originated _ -> Lwt.return Z.zero + in + let bd = + { + liquid_b; + bonds_b; + staked_b; + unstaked_frozen_b; + unstaked_finalizable_b; + staking_delegator_numerator_b; + staking_delegate_denominator_b; + } + in + return (bd, total_balance) + +let assert_balance_check ~loc ctxt account_name account_map = + let open Lwt_result_syntax in + match String.Map.find account_name account_map with + | None -> fail_account_not_found "assert_balance_check" account_name + | Some account -> + let* balance_ctxt, total_balance_ctxt = + get_balance_from_context ctxt account.contract + in + let balance, total_balance = + balance_and_total_balance_of_account account_name account_map + in + let*! r0 = + assert_pseudotokens_consistency + ~loc + balance + account + account_name + account_map + in + let*! r1 = assert_balance_equal ~loc account_name balance_ctxt balance in + let*! r1 = Assert.join_errors r0 r1 in + let*! r2 = + Assert.equal + ~loc + Tez.equal + (Format.asprintf "%s : Total balances do not match" account_name) + Tez.pp + total_balance_ctxt + total_balance + in + Assert.join_errors r1 r2 + +let log_debug_balance account_name account_map : unit = + let balance, total_balance = + balance_and_total_balance_of_account account_name account_map + in + Log.debug + "Model balance of %s:\n%aTotal balance: %a\n" + account_name + balance_pp + balance + Tez.pp + total_balance + +let log_debug_rpc_balance name contract block : unit tzresult Lwt.t = + let open Lwt_result_syntax in + let* balance, total_balance = get_balance_from_context (B block) contract in + Log.debug + "RPC balance of %s:\n%aTotal balance: %a\n" + name + balance_pp + balance + Tez.pp + total_balance ; + return_unit + +let log_debug_balance_update account_name old_account_map new_account_map : unit + = + let old_balance, old_total_balance = + balance_and_total_balance_of_account account_name old_account_map + in + let new_balance, new_total_balance = + balance_and_total_balance_of_account account_name new_account_map + in + Log.debug + "Balance update of %s:\n%aTotal balance: %a -> %a\n" + account_name + balance_update_pp + (old_balance, new_balance) + Tez.pp + old_total_balance + Tez.pp + new_total_balance + +let current_total_frozen_deposits_with_limits account_state = + Frozen_tez.total_current_with_limits + ~limit_of_staking_over_baking: + account_state.parameters.limit_of_staking_over_baking + account_state.frozen_deposits + +let update_activity account constants ~level current_cycle = + if not (Block.last_level_of_cycle constants ~level) then + {account with last_active_cycle = current_cycle} + else {account with last_active_cycle = Cycle.succ current_cycle} diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/adaptive_issuance_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/adaptive_issuance_helpers.ml index 504bb7859556cab539a570c16cc6d761eb22aa2b..111fc53c73d7c95b933f35750ac3cc67b1672105 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/adaptive_issuance_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/adaptive_issuance_helpers.ml @@ -23,1188 +23,26 @@ (* *) (*****************************************************************************) -let join_errors e1 e2 = - let open Lwt_result_syntax in - match (e1, e2) with - | Ok (), Ok () -> return_unit - | Error e, Ok () | Ok (), Error e -> fail e - | Error e1, Error e2 -> fail (e1 @ e2) - -(** Tez manipulation module *) -module Tez = struct - include Protocol.Alpha_context.Tez - - let ( + ) a b = - let open Lwt_result_wrap_syntax in - let*?@ s = a +? b in - return s - - let ( - ) a b = - let open Lwt_result_wrap_syntax in - let*?@ s = a -? b in - return s - - let ( +! ) a b = - let a = to_mutez a in - let b = to_mutez b in - Int64.add a b |> of_mutez_exn - - let ( -! ) a b = - let a = to_mutez a in - let b = to_mutez b in - Int64.sub a b |> of_mutez_exn - - let of_mutez = of_mutez_exn - - let of_z a = Z.to_int64 a |> of_mutez - - let of_q ~round_up Q.{num; den} = - (if round_up then Z.cdiv num den else Z.div num den) |> of_z - - let ratio num den = - Q.make (Z.of_int64 (to_mutez num)) (Z.of_int64 (to_mutez den)) - - let mul_q tez portion = - let tez_z = to_mutez tez |> Z.of_int64 in - Q.(mul portion ~$$tez_z) -end - -(** Representation of Tez with non integer values *) -module Partial_tez = struct - include Q - - let of_tez a = Tez.to_mutez a |> of_int64 - - let to_tez_rem {num; den} = - let tez, rem = Z.div_rem num den in - (Tez.of_z tez, rem /// den) - - let to_tez ~round_up = Tez.of_q ~round_up - - let get_rem a = snd (to_tez_rem a) - - let pp fmt a = - let tez, rem = to_tez_rem a in - (* If rem = 0, we keep the (+ 0), to indicate that it's a partial tez *) - Format.fprintf fmt "%a ( +%aµꜩ )" Tez.pp tez Q.pp_print rem -end - -module Cycle = Protocol.Alpha_context.Cycle - -(** [Frozen_tez] represents frozen stake and frozen unstaked funds. - Properties: - - sum of all current partial tez is an integer - - Can only add integer amounts - - Can always subtract integer amount (if lower than frozen amount) - - If subtracting partial amount, must be the whole frozen amount (for given contract). - The remainder is then distributed equally amongst remaining accounts, to keep property 1. - - All entries of current are positive, non zero. -*) -module Frozen_tez = struct - (* The map in current maps the stakers' name with their staked value. - It contains only delegators of the delegate which owns the frozen tez *) - type t = { - delegate : string; - initial : Tez.t; - self_current : Tez.t; - co_current : Partial_tez.t String.Map.t; - } - - let zero = - { - delegate = ""; - initial = Tez.zero; - self_current = Tez.zero; - co_current = String.Map.empty; - } - - let init amount account delegate = - if account = delegate then - { - delegate; - initial = amount; - self_current = amount; - co_current = String.Map.empty; - } - else - { - delegate; - initial = amount; - self_current = Tez.zero; - co_current = String.Map.singleton account (Partial_tez.of_tez amount); - } - - let union a b = - assert (a.delegate = b.delegate) ; - { - delegate = a.delegate; - initial = Tez.(a.initial +! b.initial); - self_current = Tez.(a.self_current +! b.self_current); - co_current = - String.Map.union - (fun _ x y -> Some Partial_tez.(x + y)) - a.co_current - b.co_current; - } - - let get account frozen_tez = - if account = frozen_tez.delegate then - Partial_tez.of_tez frozen_tez.self_current - else - match String.Map.find account frozen_tez.co_current with - | None -> Partial_tez.zero - | Some p -> p - - let total_co_current_q co_current = - String.Map.fold - (fun _ x acc -> Partial_tez.(x + acc)) - co_current - Partial_tez.zero - - let total_current a = - let r = total_co_current_q a.co_current in - let tez, rem = Partial_tez.to_tez_rem r in - assert (Q.(equal rem zero)) ; - Tez.(tez +! a.self_current) - - let add_q_to_all_co_current quantity co_current = - let s = total_co_current_q co_current in - let f p_amount = - let q = Q.div p_amount s in - Partial_tez.add p_amount (Q.mul quantity q) - in - String.Map.map f co_current - - (* For rewards, distribute equally *) - let add_tez_to_all_current tez a = - let self_portion = Tez.ratio a.self_current (total_current a) in - let self_quantity = Tez.mul_q tez self_portion |> Tez.of_q ~round_up:true in - let co_quantity = Partial_tez.of_tez Tez.(tez -! self_quantity) in - let co_current = add_q_to_all_co_current co_quantity a.co_current in - {a with co_current; self_current = Tez.(a.self_current +! self_quantity)} - - (* For slashing, slash equally *) - let sub_tez_from_all_current tez a = - let self_portion = Tez.ratio a.self_current (total_current a) in - let self_quantity = - Tez.mul_q tez self_portion |> Tez.of_q ~round_up:false - in - let self_current = - if Tez.(self_quantity >= a.self_current) then Tez.zero - else Tez.(a.self_current -! self_quantity) - in - let co_quantity = Tez.(tez -! self_quantity) in - let s = total_co_current_q a.co_current in - if Partial_tez.(geq (of_tez co_quantity) s) then - {a with self_current; co_current = String.Map.empty} - else - let f p_amount = - let q = Q.div p_amount s in - Partial_tez.sub p_amount (Tez.mul_q co_quantity q) - (* > 0 *) - in - {a with self_current; co_current = String.Map.map f a.co_current} - - (* Adds frozen to account. Happens each stake in frozen deposits *) - let add_current amount account a = - if account = a.delegate then - {a with self_current = Tez.(a.self_current +! amount)} - else - { - a with - co_current = - String.Map.update - account - (function - | None -> Some (Partial_tez.of_tez amount) - | Some q -> Some Partial_tez.(add q (of_tez amount))) - a.co_current; - } - - (* Adds frozen to account. Happens each unstake to unstaked frozen deposits *) - let add_init amount account a = union a (init amount account a.delegate) - - (* Allows amount greater than current frozen amount. - Happens each unstake in frozen deposits *) - let sub_current amount account a = - if account = a.delegate then - let amount = Tez.min amount a.self_current in - ({a with self_current = Tez.(a.self_current -! amount)}, amount) - else - match String.Map.find account a.co_current with - | None -> (a, Tez.zero) - | Some frozen -> - let amount_q = Partial_tez.of_tez amount in - if Q.(geq amount_q frozen) then - let removed, remainder = Partial_tez.to_tez_rem frozen in - let co_current = String.Map.remove account a.co_current in - let co_current = add_q_to_all_co_current remainder co_current in - ({a with co_current}, removed) - else - let co_current = - String.Map.add account Q.(frozen - amount_q) a.co_current - in - ({a with co_current}, amount) - - let sub_current_and_init amount account a = - let a, amount = sub_current amount account a in - ({a with initial = Tez.(a.initial -! amount)}, amount) - - let slash base_amount (pct : Protocol.Percentage.t) a = - let pct_q = Protocol.Percentage.to_q pct in - let slashed_amount = - Tez.mul_q base_amount pct_q |> Tez.of_q ~round_up:false - in - let total_current = total_current a in - let slashed_amount_final = Tez.min slashed_amount total_current in - (sub_tez_from_all_current slashed_amount a, slashed_amount_final) -end - -(** Representation of Unstaked frozen deposits *) -module Unstaked_frozen = struct - type r = { - cycle : Cycle.t; - (* initial total requested amount (slash ∝ initial) *) - initial : Tez.t; - (* current amount, slashes applied here *) - current : Tez.t; - (* initial requests, don't apply slash unless finalize or balance query *) - requests : Tez.t String.Map.t; - (* slash pct memory for requests *) - slash_pct : int; - } - - type t = r list - - type get_info = {cycle : Cycle.t; request : Tez.t; current : Tez.t} - - type get_info_list = get_info list - - type finalizable_info = { - amount : Tez.t; - slashed_requests : Tez.t String.Map.t; - } - - let zero = [] - - let init_r cycle request account = - { - cycle; - initial = request; - current = request; - requests = String.Map.singleton account request; - slash_pct = 0; - } - - let apply_slash_to_request slash_pct amount = - let slashed_amount = - Tez.mul_q amount Q.(slash_pct // 100) |> Tez.of_q ~round_up:true - in - Tez.(amount -! slashed_amount) - - let apply_slash_to_current slash_pct initial current = - let slashed_amount = - Tez.mul_q initial Q.(slash_pct // 100) |> Tez.of_q ~round_up:false - in - Tez.sub_opt current slashed_amount |> Option.value ~default:Tez.zero - - let remove_zeros (a : t) : t = - List.filter (fun ({current; _} : r) -> Tez.(current > zero)) a - - let get account unstaked : get_info_list = - List.filter_map - (fun {cycle; requests; slash_pct; _} -> - String.Map.find account requests - |> Option.map (fun request -> - { - cycle; - request; - current = apply_slash_to_request slash_pct request; - })) - unstaked - - let get_total account unstaked = - get account unstaked - |> List.fold_left - (fun acc ({current; _} : get_info) -> Tez.(acc +! current)) - Tez.zero - - let sum_current unstaked = - List.fold_left - (fun acc ({current; _} : r) -> Tez.(acc +! current)) - Tez.zero - unstaked - - (* Happens each unstake operation *) - let rec add_unstake cycle amount account : t -> t = function - | [] -> [init_r cycle amount account] - | ({cycle = c; requests; initial; current; slash_pct} as h) :: t -> - let open Tez in - if Cycle.equal c cycle then ( - assert (Int.equal slash_pct 0) ; - { - cycle; - initial = initial +! amount; - current = current +! amount; - slash_pct; - requests = - String.Map.update - account - (function - | None -> Some amount | Some x -> Some Tez.(x +! amount)) - requests; - } - :: t) - else h :: add_unstake cycle amount account t - - (* Happens in stake from unstake *) - let sub_unstake amount account : r -> r = - fun {cycle; requests; initial; current; slash_pct} -> - assert (slash_pct = 0) ; - let open Tez in - { - cycle; - initial = initial -! amount; - current = current -! amount; - slash_pct; - requests = - String.Map.update - account - (function - | None -> - assert (Tez.(amount = zero)) ; - None - | Some x -> - if Tez.(x = amount) then None else Some Tez.(x -! amount)) - requests; - } - - (* Makes given cycle finalizable (and unslashable) *) - let rec pop_cycle cycle : t -> finalizable_info * t = function - | [] -> ({amount = Tez.zero; slashed_requests = String.Map.empty}, []) - | ({cycle = c; requests; initial = _; current; slash_pct} as h) :: t -> - if Cycle.(c = cycle) then - let amount = current in - let slashed_requests = - String.Map.map (apply_slash_to_request slash_pct) requests - in - ({amount; slashed_requests}, t) - else if Cycle.(c < cycle) then - Stdlib.failwith - "Unstaked_frozen: found unfinalized cycle before given [cycle]. \ - Make sure to call [apply_unslashable] every cycle" - else - let info, rest = pop_cycle cycle t in - (info, h :: rest) - - let slash ~slashable_deposits_period slashed_cycle pct_times_100 a = - remove_zeros a - |> List.map - (fun - ({cycle; requests = _; initial; current; slash_pct = old_slash_pct} - as r) - -> - if - Cycle.( - cycle > slashed_cycle - || add cycle slashable_deposits_period < slashed_cycle) - then (r, Tez.zero) - else - let new_current = - apply_slash_to_current pct_times_100 initial current - in - let slashed = Tez.(current -! new_current) in - let slash_pct = min 100 (pct_times_100 + old_slash_pct) in - ({r with slash_pct; current = new_current}, slashed)) - |> List.split -end - -(** Representation of unstaked finalizable tez *) -module Unstaked_finalizable = struct - (* Slashing might put inaccessible tez in this container: they are represented in the remainder. - They still count towards the total supply, but are currently owned by noone. - At most one mutez per unstaking account per slashed cycle *) - type t = {map : Tez.t String.Map.t; remainder : Tez.t} - - let zero = {map = String.Map.empty; remainder = Tez.zero} - - (* Called when unstaked frozen for some cycle becomes finalizable *) - let add_from_poped_ufd - ({amount; slashed_requests} : Unstaked_frozen.finalizable_info) - {map; remainder} = - let total_requested = - String.Map.fold (fun _ x acc -> Tez.(x +! acc)) slashed_requests Tez.zero - in - let remainder = Tez.(remainder +! amount -! total_requested) in - let map = - String.Map.union (fun _ a b -> Some Tez.(a +! b)) map slashed_requests - in - {map; remainder} - - let total {map; remainder} = - String.Map.fold (fun _ x acc -> Tez.(x +! acc)) map remainder - - let get account {map; _} = - match String.Map.find account map with None -> Tez.zero | Some x -> x -end - (** Abstraction of the staking parameters for tests *) type staking_parameters = { limit_of_staking_over_baking : Q.t; edge_of_baking_over_staking : Q.t; } -module CycleMap = Map.Make (Cycle) - -(** Abstract information of accounts *) -type account_state = { - pkh : Signature.Public_key_hash.t; - contract : Protocol.Alpha_context.Contract.t; - delegate : string option; - parameters : staking_parameters; - liquid : Tez.t; - bonds : Tez.t; - (* The three following fields contain maps from the account's stakers to, - respectively, their frozen stake, their unstaked frozen balance, and - their unstaked finalizable funds. Additionally, [unstaked_frozen] indexes - the maps with the cycle at which the unstake operation occurred. *) - frozen_deposits : Frozen_tez.t; - unstaked_frozen : Unstaked_frozen.t; - unstaked_finalizable : Unstaked_finalizable.t; - staking_delegator_numerator : Z.t; - staking_delegate_denominator : Z.t; - frozen_rights : Tez.t CycleMap.t; - slashed_cycles : Cycle.t list; -} - -let init_account ?delegate ~pkh ~contract ~parameters ?(liquid = Tez.zero) - ?(bonds = Tez.zero) ?(frozen_deposits = Frozen_tez.zero) - ?(unstaked_frozen = Unstaked_frozen.zero) - ?(unstaked_finalizable = Unstaked_finalizable.zero) - ?(staking_delegator_numerator = Z.zero) - ?(staking_delegate_denominator = Z.zero) ?(frozen_rights = CycleMap.empty) - ?(slashed_cycles = []) () = - { - pkh; - contract; - delegate; - parameters; - liquid; - bonds; - frozen_deposits; - unstaked_frozen; - unstaked_finalizable; - staking_delegator_numerator; - staking_delegate_denominator; - frozen_rights; - slashed_cycles; - } - -type account_map = account_state String.Map.t - -(** Balance returned by RPCs. Partial tez are rounded down *) -type balance = { - liquid_b : Tez.t; - bonds_b : Tez.t; - staked_b : Partial_tez.t; - unstaked_frozen_b : Tez.t; - unstaked_finalizable_b : Tez.t; - staking_delegator_numerator_b : Z.t; - staking_delegate_denominator_b : Z.t; -} - -let balance_zero = - { - liquid_b = Tez.zero; - bonds_b = Tez.zero; - staked_b = Partial_tez.zero; - unstaked_frozen_b = Tez.zero; - unstaked_finalizable_b = Tez.zero; - staking_delegator_numerator_b = Z.zero; - staking_delegate_denominator_b = Z.zero; - } - -let balance_of_account account_name (account_map : account_map) = - match String.Map.find account_name account_map with - | None -> raise Not_found - | Some - { - pkh = _; - contract = _; - delegate; - parameters = _; - liquid; - bonds; - frozen_deposits = _; - unstaked_frozen = _; - unstaked_finalizable = _; - staking_delegator_numerator; - staking_delegate_denominator; - frozen_rights = _; - slashed_cycles = _; - } -> - let balance = +let default_params = + let Protocol.Staking_parameters_repr. { - balance_zero with - liquid_b = liquid; - bonds_b = bonds; - staking_delegator_numerator_b = staking_delegator_numerator; - staking_delegate_denominator_b = staking_delegate_denominator; - } - in - let balance = - match delegate with - | None -> balance - | Some d -> ( - match String.Map.find d account_map with - | None -> raise Not_found - | Some delegate_account -> - { - balance with - staked_b = - Frozen_tez.get account_name delegate_account.frozen_deposits; - }) - in - (* Because an account can still have frozen or finalizable funds from a delegate - that is not its own, we iterate over all of them *) - let unstaked_frozen_b, unstaked_finalizable_b = - String.Map.fold - (fun _delegate_name delegate (frozen, finalzbl) -> - let frozen = - Tez.( - frozen - +! Unstaked_frozen.get_total - account_name - delegate.unstaked_frozen) - in - let finalzbl = - Tez.( - finalzbl - +! Unstaked_finalizable.get - account_name - delegate.unstaked_finalizable) - in - (frozen, finalzbl)) - account_map - (Tez.zero, Tez.zero) - in - {balance with unstaked_frozen_b; unstaked_finalizable_b} - -let balance_pp fmt - { - liquid_b; - bonds_b; - staked_b; - unstaked_frozen_b; - unstaked_finalizable_b; - staking_delegator_numerator_b; - staking_delegate_denominator_b; - } = - Format.fprintf - fmt - "{@;\ - @[ liquid : %a@;\ - bonds : %a@;\ - staked : %a@;\ - unstaked_frozen : %a@;\ - unstaked_finalizable : %a@;\ - staking_delegator_numerator : %a@;\ - staking_delegate_denominator : %a@;\ - }@." - Tez.pp - liquid_b - Tez.pp - bonds_b - Partial_tez.pp - staked_b - Tez.pp - unstaked_frozen_b - Tez.pp - unstaked_finalizable_b - Z.pp_print - staking_delegator_numerator_b - Z.pp_print - staking_delegate_denominator_b - -let balance_update_pp fmt - ( { - liquid_b = a_liquid_b; - bonds_b = a_bonds_b; - staked_b = a_staked_b; - unstaked_frozen_b = a_unstaked_frozen_b; - unstaked_finalizable_b = a_unstaked_finalizable_b; - staking_delegator_numerator_b = a_staking_delegator_numerator_b; - staking_delegate_denominator_b = a_staking_delegate_denominator_b; - }, - { - liquid_b = b_liquid_b; - bonds_b = b_bonds_b; - staked_b = b_staked_b; - unstaked_frozen_b = b_unstaked_frozen_b; - unstaked_finalizable_b = b_unstaked_finalizable_b; - staking_delegator_numerator_b = b_staking_delegator_numerator_b; - staking_delegate_denominator_b = b_staking_delegate_denominator_b; - } ) = - Format.fprintf - fmt - "{@;\ - @[ liquid : %a -> %a@;\ - bonds : %a -> %a@;\ - staked : %a -> %a@;\ - unstaked_frozen : %a -> %a@;\ - unstaked_finalizable : %a -> %a@;\ - staking_delegator_numerator : %a -> %a@;\ - staking_delegate_denominator : %a -> %a@;\ - }@." - Tez.pp - a_liquid_b - Tez.pp - b_liquid_b - Tez.pp - a_bonds_b - Tez.pp - b_bonds_b - Partial_tez.pp - a_staked_b - Partial_tez.pp - b_staked_b - Tez.pp - a_unstaked_frozen_b - Tez.pp - b_unstaked_frozen_b - Tez.pp - a_unstaked_finalizable_b - Tez.pp - b_unstaked_finalizable_b - Z.pp_print - a_staking_delegator_numerator_b - Z.pp_print - b_staking_delegator_numerator_b - Z.pp_print - a_staking_delegate_denominator_b - Z.pp_print - b_staking_delegate_denominator_b - -let assert_balance_equal ~loc account_name - { - liquid_b = a_liquid_b; - bonds_b = a_bonds_b; - staked_b = a_staked_b; - unstaked_frozen_b = a_unstaked_frozen_b; - unstaked_finalizable_b = a_unstaked_finalizable_b; - staking_delegator_numerator_b = a_staking_delegator_numerator_b; - staking_delegate_denominator_b = a_staking_delegate_denominator_b; - } - { - liquid_b = b_liquid_b; - bonds_b = b_bonds_b; - staked_b = b_staked_b; - unstaked_frozen_b = b_unstaked_frozen_b; - unstaked_finalizable_b = b_unstaked_finalizable_b; - staking_delegator_numerator_b = b_staking_delegator_numerator_b; - staking_delegate_denominator_b = b_staking_delegate_denominator_b; - } = - let open Lwt_result_syntax in - let f s = Format.asprintf "%s: %s" account_name s in - let* () = - List.fold_left - (fun a b -> - let*! a in - let*! b in - join_errors a b) - return_unit - [ - Assert.equal - ~loc - Tez.equal - (f "Liquid balances do not match") - Tez.pp - a_liquid_b - b_liquid_b; - Assert.equal - ~loc - Tez.equal - (f "Bonds balances do not match") - Tez.pp - a_bonds_b - b_bonds_b; - Assert.equal - ~loc - Tez.equal - (f "Staked balances do not match") - Tez.pp - (Partial_tez.to_tez ~round_up:false a_staked_b) - (Partial_tez.to_tez ~round_up:false b_staked_b); - Assert.equal - ~loc - Tez.equal - (f "Unstaked frozen balances do not match") - Tez.pp - a_unstaked_frozen_b - b_unstaked_frozen_b; - Assert.equal - ~loc - Tez.equal - (f "Unstaked finalizable balances do not match") - Tez.pp - a_unstaked_finalizable_b - b_unstaked_finalizable_b; - Assert.equal - ~loc - Z.equal - (f "Staking delegator numerators do not match") - Z.pp_print - a_staking_delegator_numerator_b - b_staking_delegator_numerator_b; - Assert.equal - ~loc - Z.equal - (f "Staking delegate denominators do not match") - Z.pp_print - a_staking_delegate_denominator_b - b_staking_delegate_denominator_b; - ] - in - return_unit - -let update_account ~f account_name account_map = - String.Map.update - account_name - (function None -> raise Not_found | Some x -> Some (f x)) - account_map - -let add_liquid_rewards amount account_name account_map = - let f account = - let liquid = Tez.(account.liquid +! amount) in - {account with liquid} - in - update_account ~f account_name account_map - -let add_frozen_rewards amount account_name account_map = - let f account = - let frozen_deposits = - Frozen_tez.add_tez_to_all_current amount account.frozen_deposits - in - {account with frozen_deposits} - in - update_account ~f account_name account_map - -let apply_burn amount src_name account_map = - let f src = {src with liquid = Tez.(src.liquid -! amount)} in - update_account ~f src_name account_map - -let apply_transfer amount src_name dst_name account_map = - match - (String.Map.find src_name account_map, String.Map.find dst_name account_map) - with - | Some src, Some _ -> - if Tez.(src.liquid < amount) then - (* Invalid amount: operation will fail *) - account_map - else - let f_src src = - let liquid = Tez.(src.liquid -! amount) in - {src with liquid} - in - let f_dst dst = - let liquid = Tez.(dst.liquid +! amount) in - {dst with liquid} - in - let account_map = update_account ~f:f_src src_name account_map in - update_account ~f:f_dst dst_name account_map - | _ -> raise Not_found - -let stake_from_unstake amount current_cycle consensus_rights_delay delegate_name - account_map = - match String.Map.find delegate_name account_map with - | None -> raise Not_found - | Some ({unstaked_frozen; frozen_deposits; slashed_cycles; _} as account) -> - let oldest_slashable_cycle = - Cycle.(sub current_cycle (consensus_rights_delay + 1)) - |> Option.value ~default:Cycle.root - in - if - List.exists - (fun x -> Cycle.(x >= oldest_slashable_cycle)) - slashed_cycles - then (account_map, amount) - else - let unstaked_frozen = - List.sort - (fun (Unstaked_frozen.{cycle = cycle1; _} : Unstaked_frozen.r) - {cycle = cycle2; _} -> Cycle.compare cycle2 cycle1) - unstaked_frozen - in - let rec aux acc_unstakes rem_amount rem_unstakes = - match rem_unstakes with - | [] -> (acc_unstakes, rem_amount) - | (Unstaked_frozen.{initial; _} as h) :: t -> - if Tez.(rem_amount = zero) then - (acc_unstakes @ rem_unstakes, Tez.zero) - else if Tez.(rem_amount >= initial) then - let h = Unstaked_frozen.sub_unstake initial delegate_name h in - let rem_amount = Tez.(rem_amount -! initial) in - aux (acc_unstakes @ [h]) rem_amount t - else - let h = - Unstaked_frozen.sub_unstake rem_amount delegate_name h - in - (acc_unstakes @ [h] @ t, Tez.zero) - in - let unstaked_frozen, rem_amount = aux [] amount unstaked_frozen in - let frozen_deposits = - Frozen_tez.add_current - Tez.(amount -! rem_amount) - delegate_name - frozen_deposits - in - let account = {account with unstaked_frozen; frozen_deposits} in - let account_map = - update_account ~f:(fun _ -> account) delegate_name account_map - in - (account_map, rem_amount) - -let apply_stake amount current_cycle consensus_rights_delay staker_name - account_map = - match String.Map.find staker_name account_map with - | None -> raise Not_found - | Some staker -> ( - match staker.delegate with - | None -> - (* Invalid operation: no delegate *) - account_map - | Some delegate_name -> - let old_account_map = account_map in - let account_map, amount = - if delegate_name = staker_name then - stake_from_unstake - amount - current_cycle - consensus_rights_delay - staker_name - account_map - else (account_map, amount) - in - if Tez.(staker.liquid < amount) then - (* Invalid amount: operation will fail *) - old_account_map - else - let f_staker staker = - let liquid = Tez.(staker.liquid -! amount) in - {staker with liquid} - in - let f_delegate delegate = - let frozen_deposits = - Frozen_tez.add_current - amount - staker_name - delegate.frozen_deposits - in - {delegate with frozen_deposits} - in - let account_map = - update_account ~f:f_staker staker_name account_map - in - update_account ~f:f_delegate delegate_name account_map) - -let apply_unstake cycle amount staker_name account_map = - match String.Map.find staker_name account_map with - | None -> raise Not_found - | Some staker -> ( - match staker.delegate with - | None -> (* Invalid operation: no delegate *) account_map - | Some delegate_name -> ( - match String.Map.find delegate_name account_map with - | None -> raise Not_found - | Some delegate -> - let frozen_deposits, amount_unstaked = - Frozen_tez.sub_current - amount - staker_name - delegate.frozen_deposits - in - let delegate = {delegate with frozen_deposits} in - let account_map = - String.Map.add delegate_name delegate account_map - in - let f delegate = - let unstaked_frozen = - Unstaked_frozen.add_unstake - cycle - amount_unstaked - staker_name - delegate.unstaked_frozen - in - {delegate with unstaked_frozen} - in - update_account ~f delegate_name account_map)) - -let apply_unslashable_f cycle delegate = - let amount_unslashable, unstaked_frozen = - Unstaked_frozen.pop_cycle cycle delegate.unstaked_frozen - in - let unstaked_finalizable = - Unstaked_finalizable.add_from_poped_ufd - amount_unslashable - delegate.unstaked_finalizable - in - {delegate with unstaked_frozen; unstaked_finalizable} - -(* Updates unstaked unslashable values for given account *) -let apply_unslashable cycle account_name account_map = - update_account ~f:(apply_unslashable_f cycle) account_name account_map - -(* Updates unstaked unslashable values in all accounts *) -let apply_unslashable_for_all cycle account_map = - String.Map.map (apply_unslashable_f cycle) account_map - -let apply_finalize staker_name account_map = - match String.Map.find staker_name account_map with - | None -> raise Not_found - | Some _staker -> - (* Because an account can still have finalizable funds from a delegate - that is not its own, we iterate over all of them *) - String.Map.fold - (fun delegate_name delegate account_map_acc -> - match - String.Map.find staker_name delegate.unstaked_finalizable.map - with - | None -> account_map_acc - | Some amount -> - let f_staker staker = - let liquid = Tez.(staker.liquid +! amount) in - {staker with liquid} - in - let f_delegate delegate = - let map = - String.Map.remove - staker_name - delegate.unstaked_finalizable.map - in - { - delegate with - unstaked_finalizable = - {delegate.unstaked_finalizable with map}; - } - in - let account_map_acc = - update_account ~f:f_staker staker_name account_map_acc - in - update_account ~f:f_delegate delegate_name account_map_acc) - account_map - account_map - -let balance_and_total_balance_of_account account_name account_map = - let ({ - liquid_b; - bonds_b; - staked_b; - unstaked_frozen_b; - unstaked_finalizable_b; - staking_delegator_numerator_b = _; - staking_delegate_denominator_b = _; - } as balance) = - balance_of_account account_name account_map - in - ( balance, - Tez.( - liquid_b +! bonds_b - +! Partial_tez.to_tez ~round_up:false staked_b - +! unstaked_frozen_b +! unstaked_finalizable_b) ) - -let apply_slashing - ( culprit, - Protocol.Denunciations_repr.{rewarded; misbehaviour; operation_hash = _} - ) constants account_map = - let find_account_name_from_pkh_exn pkh account_map = - match - Option.map - fst - String.Map.( - choose - @@ filter - (fun _ account -> - Signature.Public_key_hash.equal pkh account.pkh) - account_map) - with - | None -> assert false - | Some x -> x - in - let slashed_cycle = - Block.current_cycle_of_level - ~blocks_per_cycle: - constants.Protocol.Alpha_context.Constants.Parametric.blocks_per_cycle - ~current_level:(Protocol.Raw_level_repr.to_int32 misbehaviour.level) - in - let culprit_name = find_account_name_from_pkh_exn culprit account_map in - let rewarded_name = find_account_name_from_pkh_exn rewarded account_map in - let slashed_pct = - match misbehaviour.kind with - | Double_baking -> - constants - .Protocol.Alpha_context.Constants.Parametric - .percentage_of_frozen_deposits_slashed_per_double_baking - | Double_attesting | Double_preattesting -> - constants.percentage_of_frozen_deposits_slashed_per_double_attestation - in - let get_total_supply acc_map = - String.Map.fold - (fun _name - { - pkh = _; - contract = _; - delegate = _; - parameters = _; - liquid; - bonds; - frozen_deposits; - unstaked_frozen; - unstaked_finalizable; - staking_delegator_numerator = _; - staking_delegate_denominator = _; - frozen_rights = _; - slashed_cycles = _; - } - tot -> - Tez.( - liquid +! bonds - +! Frozen_tez.total_current frozen_deposits - +! Unstaked_frozen.sum_current unstaked_frozen - +! Unstaked_finalizable.total unstaked_finalizable - +! tot)) - acc_map - Tez.zero - in - let total_before_slash = get_total_supply account_map in - let slash_culprit - ({frozen_deposits; unstaked_frozen; frozen_rights; _} as acc) = - let base_rights = - CycleMap.find slashed_cycle frozen_rights - |> Option.value ~default:Tez.zero - in - let frozen_deposits, slashed_frozen = - Frozen_tez.slash base_rights slashed_pct frozen_deposits - in - let slashed_pct_q = Protocol.Percentage.to_q slashed_pct in - let slashed_pct = Q.(100 // 1 * slashed_pct_q |> to_int) in - let unstaked_frozen, slashed_unstaked = - Unstaked_frozen.slash - ~slashable_deposits_period:constants.consensus_rights_delay - slashed_cycle - slashed_pct - unstaked_frozen - in - ( {acc with frozen_deposits; unstaked_frozen}, - slashed_frozen :: slashed_unstaked ) - in - let culprit_account = - String.Map.find culprit_name account_map - |> Option.value_f ~default:(fun () -> raise Not_found) - in - let slashed_culprit_account, total_slashed = slash_culprit culprit_account in - let account_map = - update_account - ~f:(fun _ -> slashed_culprit_account) - culprit_name - account_map - in - let total_after_slash = get_total_supply account_map in - let portion_reward = - constants.adaptive_issuance.global_limit_of_staking_over_baking + 2 - in - (* For each container slashed, the snitch gets a reward transferred. It gets rounded - down each time *) - let reward_to_snitch = - List.map - (fun x -> Tez.mul_q x Q.(1 // portion_reward) |> Tez.of_q ~round_up:false) - total_slashed - |> List.fold_left Tez.( +! ) Tez.zero - in - let account_map = - add_liquid_rewards reward_to_snitch rewarded_name account_map - in - let actual_total_burnt_amount = - Tez.(total_before_slash -! total_after_slash -! reward_to_snitch) + limit_of_staking_over_baking_millionth; + edge_of_baking_over_staking_billionth; + } = + Protocol.Staking_parameters_repr.default in - (account_map, actual_total_burnt_amount) - -(* Given cycle is the cycle for which the rights are computed, usually current + - consensus rights delay *) -let update_frozen_rights_cycle cycle account_map = - String.Map.map - (fun ({frozen_deposits; frozen_rights; _} as acc) -> - let total_frozen = Frozen_tez.total_current frozen_deposits in - let frozen_rights = CycleMap.add cycle total_frozen frozen_rights in - {acc with frozen_rights}) - account_map - -let get_balance_from_context ctxt contract = - let open Lwt_result_syntax in - let* liquid_b = Context.Contract.balance ctxt contract in - let* bonds_b = Context.Contract.frozen_bonds ctxt contract in - let* staked_b = Context.Contract.staked_balance ctxt contract in - let staked_b = - Option.value ~default:Tez.zero staked_b |> Partial_tez.of_tez - in - let* unstaked_frozen_b = - Context.Contract.unstaked_frozen_balance ctxt contract - in - let unstaked_frozen_b = Option.value ~default:Tez.zero unstaked_frozen_b in - let* unstaked_finalizable_b = - Context.Contract.unstaked_finalizable_balance ctxt contract - in - let unstaked_finalizable_b = - Option.value ~default:Tez.zero unstaked_finalizable_b - in - let* total_balance = Context.Contract.full_balance ctxt contract in - let* staking_delegator_numerator_b = - Context.Contract.staking_numerator ctxt contract - in - let*! staking_delegate_denominator_b = - match (contract : Protocol.Alpha_context.Contract.t) with - | Implicit pkh -> - let*! result = Context.Delegate.staking_denominator ctxt pkh in - Lwt.return - (match result with - | Ok v -> v - | Error _ -> (* Not a delegate *) Z.zero) - | Originated _ -> Lwt.return Z.zero - in - let bd = - { - liquid_b; - bonds_b; - staked_b; - unstaked_frozen_b; - unstaked_finalizable_b; - staking_delegator_numerator_b; - staking_delegate_denominator_b; - } - in - return (bd, total_balance) - -let assert_balance_check ~loc ctxt account_name account_map = - let open Lwt_result_syntax in - match String.Map.find account_name account_map with - | None -> raise Not_found - | Some account -> - let* balance_ctxt, total_balance_ctxt = - get_balance_from_context ctxt account.contract - in - let balance, total_balance = - balance_and_total_balance_of_account account_name account_map - in - let*! r1 = assert_balance_equal ~loc account_name balance_ctxt balance in - let*! r2 = - Assert.equal - ~loc - Tez.equal - (Format.asprintf "%s : Total balances do not match" account_name) - Tez.pp - total_balance_ctxt - total_balance - in - join_errors r1 r2 + { + limit_of_staking_over_baking = + Q.(Int32.to_int limit_of_staking_over_baking_millionth // 1_000_000); + edge_of_baking_over_staking = + Q.(Int32.to_int edge_of_baking_over_staking_billionth // 1_000_000_000); + } let get_launch_cycle ~loc blk = let open Lwt_result_syntax in @@ -1217,7 +55,7 @@ let stake ctxt contract amount = Op.transaction ctxt ~entrypoint:Protocol.Alpha_context.Entrypoint.stake - ~fee:Tez.zero + ~fee:Tez_helpers.zero contract contract amount @@ -1243,34 +81,36 @@ let set_delegate_parameters ctxt delegate ctxt ~entrypoint ~parameters - ~fee:Tez.zero + ~fee:Tez_helpers.zero delegate delegate - Tez.zero + Tez_helpers.zero let unstake ctxt contract amount = Op.transaction ctxt ~entrypoint:Protocol.Alpha_context.Entrypoint.unstake - ~fee:Tez.zero + ~fee:Tez_helpers.zero contract contract amount -let finalize_unstake ctxt ?(amount = Tez.zero) contract = +let finalize_unstake ctxt ?(amount = Tez_helpers.zero) contract = Op.transaction ctxt ~entrypoint:Protocol.Alpha_context.Entrypoint.finalize_unstake - ~fee:Tez.zero + ~fee:Tez_helpers.zero contract contract amount -let portion_of_rewards_to_liquid_for_cycle ?policy ctxt cycle pkh rewards = +let portion_of_rewards_to_liquid_for_cycle ctxt cycle pkh rewards = let open Lwt_result_syntax in let* {frozen; weighted_delegated} = - Context.Delegate.stake_for_cycle ?policy ctxt cycle pkh + Context.Delegate.stake_for_cycle ctxt cycle pkh + in + let portion = + Tez_helpers.(ratio weighted_delegated (frozen +! weighted_delegated)) in - let portion = Tez.(ratio weighted_delegated (frozen +! weighted_delegated)) in - let to_liquid = Tez.mul_q rewards portion in - return (Partial_tez.to_tez ~round_up:false to_liquid) + let to_liquid = Tez_helpers.mul_q rewards portion in + return (Tez_helpers.of_q ~round:`Down to_liquid) diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/assert.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/assert.ml index 9f42a9e2ec7cfcfad6b6d864a3d15e7ad548fec8..2e00f89b65d602bcfb54204bb1c24feead04ea28 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/assert.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/assert.ml @@ -33,6 +33,13 @@ let error ~loc v f = | Ok _ -> failwith "Unexpected successful result (%s)" loc | Error err -> failwith "@[Unexpected error (%s): %a@]" loc pp_print_trace err +let join_errors e1 e2 = + let open Lwt_result_syntax in + match (e1, e2) with + | Ok (), Ok () -> return_unit + | Error e, Ok () | Ok (), Error e -> fail e + | Error e1, Error e2 -> fail (e1 @ e2) + let test_error_encodings e = let module E = Environment.Error_monad in ignore (E.pp Format.str_formatter e) ; @@ -64,6 +71,30 @@ let proto_error_with_info ?(error_info_field = `Title) ~loc v let info = info err in String.equal info expected_error_info) +let as_proto_error = function + | Environment.Ecoproto_error err -> Ok err + | err -> Error err + +(** Similar to {!proto_error}, except that [errs] is directly an error + trace instead of a [tzresult]. + + [expect_error ~loc errs] has the right type to be used as the + [expect_failure] or [expect_apply_failure] argument of + {!Incremental.add_operation}. *) +let expect_error ~loc errs f = + let open Lwt_result_syntax in + let proto_errs = List.map_e as_proto_error errs in + match proto_errs with + | Ok proto_errs when f proto_errs -> + List.iter test_error_encodings proto_errs ; + return_unit + | Ok _ | Error _ -> + failwith + "%s: expected a specific error, but instead got:@, %a" + loc + Error_monad.pp_print_trace + errs + let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = let open Lwt_result_syntax in if not (cmp a b) then @@ -312,6 +343,20 @@ let assert_equal_list_opt ~loc eq msg pp = msg (Format.pp_print_option (pp_print_list pp)) +(** Checks that both lists have the same elements, not taking the + order of these elements into account, but taking their + multiplicity into account. *) +let equal_list_any_order ~loc ~compare msg pp list1 list2 = + let ordered_list1 = List.sort compare list1 in + let ordered_list2 = List.sort compare list2 in + equal + ~loc + (List.equal (fun a b -> compare a b = 0)) + msg + (pp_print_list pp) + ordered_list1 + ordered_list2 + let to_json_string encoding x = x |> Data_encoding.Json.construct encoding diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/block.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/block.ml index bace2e618fd6860f291fff7d401f5a8858959501..f40e9af073e0d8162e9de6e8356d0daea262d5a6 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/block.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/block.ml @@ -121,9 +121,26 @@ let get_next_baker_by_account pkh block = round, WithExceptions.Option.to_exn ~none:(Failure __LOC__) timestamp ) +(* Returns the first baker able to bake that is not in the list of excluded keys. *) let get_next_baker_excluding excludes block = let open Lwt_result_wrap_syntax in let* bakers = Plugin.RPC.Baking_rights.get rpc_ctxt block in + let* baker_opt = + List.find_es + (fun {Plugin.RPC.Baking_rights.consensus_key; delegate; _} -> + let* info = Plugin.RPC.Delegates.info rpc_ctxt block delegate in + let* forbidden = + Plugin.RPC.Staking.is_forbidden rpc_ctxt block delegate + in + return + @@ ((not info.deactivated) && (not forbidden) + && not + (List.mem + ~equal:Signature.Public_key_hash.equal + consensus_key + excludes))) + bakers + in let { Plugin.RPC.Baking_rights.delegate = pkh; consensus_key; @@ -131,15 +148,7 @@ let get_next_baker_excluding excludes block = round; _; } = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.find - (fun {Plugin.RPC.Baking_rights.consensus_key; _} -> - not - (List.mem - ~equal:Signature.Public_key_hash.equal - consensus_key - excludes)) - bakers + WithExceptions.Option.get ~loc:__LOC__ baker_opt in let*?@ round = Round.to_int round in return @@ -1246,12 +1255,14 @@ let current_cycle b = let current_level = b.header.shell.level in current_cycle_of_level ~blocks_per_cycle ~current_level -let last_block_of_cycle b = - let blocks_per_cycle = b.constants.blocks_per_cycle in - let current_level = b.header.shell.level in - let mod_plus_one = Int32.(rem (succ current_level) blocks_per_cycle) in +let last_level_of_cycle (constants : Constants.Parametric.t) ~level = + let blocks_per_cycle = constants.blocks_per_cycle in + let mod_plus_one = Int32.(rem (succ level) blocks_per_cycle) in Int32.(equal mod_plus_one zero) +let last_block_of_cycle b = + last_level_of_cycle b.constants ~level:b.header.shell.level + let bake_until_cycle ?baking_mode ?policy cycle (b : t) = let open Lwt_result_syntax in let* final_block_of_previous_cycle = diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/block.mli b/src/proto_019_PtParisB/lib_protocol/test/helpers/block.mli index 02fe3efa0ec72b362bd49ccf331d3fed441b32f6..401382c096ebddaf8eaa481839b406c0b9858c57 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/block.mli +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/block.mli @@ -43,7 +43,7 @@ val rpc_ctxt : t Environment.RPC_context.simple (** Policies to select the next baker: - [By_round r] selects the baker at round [r] - [By_account pkh] selects the first slot for baker [pkh] - - [Excluding pkhs] selects the first baker that doesn't belong to [pkhs] + - [Excluding pkhs] selects the first valid baker that doesn't belong to [pkhs] Note that bakers can have active consensus keys different from their regular delegate keys. For the [By_account pkh] policy, [pkh] @@ -354,6 +354,8 @@ val current_cycle_of_level : val current_cycle : block -> Cycle.t +val last_level_of_cycle : Constants.Parametric.t -> level:int32 -> bool + val last_block_of_cycle : block -> bool (** Given a block [b] at level [l] bakes enough blocks to complete a cycle, diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/constants_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/constants_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..bb06992ed0e0c035592238d05934a3428ac4c4f7 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/constants_helpers.ml @@ -0,0 +1,194 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +type t = Protocol.Alpha_context.Constants.Parametric.t + +(* Warning: not a Set *) +module Set = struct + let consensus_rights_delay consensus_rights_delay (c : t) = + {c with consensus_rights_delay} + + let blocks_preservation_cycles blocks_preservation_cycles (c : t) = + {c with blocks_preservation_cycles} + + let delegate_parameters_activation_delay delegate_parameters_activation_delay + (c : t) = + {c with delegate_parameters_activation_delay} + + let blocks_per_cycle blocks_per_cycle (c : t) = {c with blocks_per_cycle} + + let blocks_per_commitment blocks_per_commitment (c : t) = + {c with blocks_per_commitment} + + let nonce_revelation_threshold nonce_revelation_threshold (c : t) = + {c with nonce_revelation_threshold} + + let cycles_per_voting_period cycles_per_voting_period (c : t) = + {c with cycles_per_voting_period} + + let hard_gas_limit_per_operation hard_gas_limit_per_operation (c : t) = + {c with hard_gas_limit_per_operation} + + let hard_gas_limit_per_block hard_gas_limit_per_block (c : t) = + {c with hard_gas_limit_per_block} + + let proof_of_work_threshold proof_of_work_threshold (c : t) = + {c with proof_of_work_threshold} + + let minimal_stake minimal_stake (c : t) = {c with minimal_stake} + + let minimal_frozen_stake minimal_frozen_stake (c : t) = + {c with minimal_frozen_stake} + + let vdf_difficulty vdf_difficulty (c : t) = {c with vdf_difficulty} + + let origination_size origination_size (c : t) = {c with origination_size} + + let cost_per_byte cost_per_byte (c : t) = {c with cost_per_byte} + + let hard_storage_limit_per_operation hard_storage_limit_per_operation (c : t) + = + {c with hard_storage_limit_per_operation} + + let quorum_min quorum_min (c : t) = {c with quorum_min} + + let quorum_max quorum_max (c : t) = {c with quorum_max} + + let min_proposal_quorum min_proposal_quorum (c : t) = + {c with min_proposal_quorum} + + let liquidity_baking_subsidy liquidity_baking_subsidy (c : t) = + {c with liquidity_baking_subsidy} + + let liquidity_baking_toggle_ema_threshold + liquidity_baking_toggle_ema_threshold (c : t) = + {c with liquidity_baking_toggle_ema_threshold} + + let max_operations_time_to_live max_operations_time_to_live (c : t) = + {c with max_operations_time_to_live} + + let minimal_block_delay minimal_block_delay (c : t) = + {c with minimal_block_delay} + + let delay_increment_per_round delay_increment_per_round (c : t) = + {c with delay_increment_per_round} + + let minimal_participation_ratio minimal_participation_ratio (c : t) = + {c with minimal_participation_ratio} + + let consensus_committee_size consensus_committee_size (c : t) = + {c with consensus_committee_size} + + let consensus_threshold consensus_threshold (c : t) = + {c with consensus_threshold} + + let limit_of_delegation_over_baking limit_of_delegation_over_baking (c : t) = + {c with limit_of_delegation_over_baking} + + let percentage_of_frozen_deposits_slashed_per_double_baking + percentage_of_frozen_deposits_slashed_per_double_baking (c : t) = + {c with percentage_of_frozen_deposits_slashed_per_double_baking} + + let percentage_of_frozen_deposits_slashed_per_double_attestation + percentage_of_frozen_deposits_slashed_per_double_attestation (c : t) = + {c with percentage_of_frozen_deposits_slashed_per_double_attestation} + + let max_slashing_per_block max_slashing_per_block (c : t) = + {c with max_slashing_per_block} + + let max_slashing_threshold max_slashing_threshold (c : t) = + {c with max_slashing_threshold} + + let testnet_dictator testnet_dictator (c : t) = {c with testnet_dictator} + + let initial_seed initial_seed (c : t) = {c with initial_seed} + + let cache_script_size cache_script_size (c : t) = {c with cache_script_size} + + let cache_stake_distribution_cycles cache_stake_distribution_cycles (c : t) = + {c with cache_stake_distribution_cycles} + + let cache_sampler_state_cycles cache_sampler_state_cycles (c : t) = + {c with cache_sampler_state_cycles} + + let dal dal (c : t) = {c with dal} + + let sc_rollup sc_rollup (c : t) = {c with sc_rollup} + + let zk_rollup zk_rollup (c : t) = {c with zk_rollup} + + let direct_ticket_spending_enable direct_ticket_spending_enable (c : t) = + {c with direct_ticket_spending_enable} + + let issuance_weights issuance_weights (c : t) = {c with issuance_weights} + + module Issuance_weights = struct + let base_total_issued_per_minute base_total_issued_per_minute (c : t) = + issuance_weights {c.issuance_weights with base_total_issued_per_minute} c + end + + let adaptive_issuance adaptive_issuance (c : t) = {c with adaptive_issuance} + + module Adaptive_issuance = struct + let activation_vote_enable activation_vote_enable (c : t) = + adaptive_issuance {c.adaptive_issuance with activation_vote_enable} c + + let autostaking_enable autostaking_enable (c : t) = + adaptive_issuance {c.adaptive_issuance with autostaking_enable} c + + let force_activation force_activation (c : t) = + adaptive_issuance {c.adaptive_issuance with force_activation} c + + let ns_enable ns_enable (c : t) = + adaptive_issuance {c.adaptive_issuance with ns_enable} c + + let launch_ema_threshold launch_ema_threshold (c : t) = + adaptive_issuance {c.adaptive_issuance with launch_ema_threshold} c + + let adaptive_rewards_params adaptive_rewards_params (c : t) = + adaptive_issuance {c.adaptive_issuance with adaptive_rewards_params} c + + module Adaptive_rewards_params = struct + let max_bonus max_bonus (c : t) = + adaptive_rewards_params + {c.adaptive_issuance.adaptive_rewards_params with max_bonus} + c + + let issuance_ratio_final_min issuance_ratio_final_min (c : t) = + adaptive_rewards_params + { + c.adaptive_issuance.adaptive_rewards_params with + issuance_ratio_final_min; + } + c + + let issuance_ratio_final_max issuance_ratio_final_max (c : t) = + adaptive_rewards_params + { + c.adaptive_issuance.adaptive_rewards_params with + issuance_ratio_final_max; + } + c + + let issuance_ratio_initial_min issuance_ratio_initial_min (c : t) = + adaptive_rewards_params + { + c.adaptive_issuance.adaptive_rewards_params with + issuance_ratio_initial_min; + } + c + + let issuance_ratio_initial_max issuance_ratio_initial_max (c : t) = + adaptive_rewards_params + { + c.adaptive_issuance.adaptive_rewards_params with + issuance_ratio_initial_max; + } + c + end + end +end diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/context.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/context.ml index 77bbac4a3b8c8fffdc150b87cc032461f678cbf1..8709a4659a44fa4de60f86b7066070f148be03b9 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/context.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/context.ml @@ -29,12 +29,14 @@ open Alpha_context type t = B of Block.t | I of Incremental.t -let get_alpha_ctxt ?(policy = Block.By_round 0) c = +(* Begins the construction of a block with the first available baker. + Fails if no baker can bake the next block. *) +let get_alpha_ctxt c = let open Lwt_result_syntax in match c with | I i -> return (Incremental.alpha_ctxt i) | B b -> - let* i = Incremental.begin_construction ~policy b in + let* i = Incremental.begin_construction ~policy:(Block.Excluding []) b in return (Incremental.alpha_ctxt i) let branch = function B b -> b.hash | I i -> (Incremental.predecessor i).hash @@ -266,7 +268,7 @@ let get_bonus_reward ctxt ~attesting_power = ~reward_kind:Baking_reward_bonus_per_slot in let multiplier = max 0 (attesting_power - consensus_threshold) in - return Test_tez.(baking_reward_bonus_per_slot *! Int64.of_int multiplier) + return Tez_helpers.(baking_reward_bonus_per_slot *! Int64.of_int multiplier) let get_attesting_reward ctxt ~expected_attesting_power = let open Lwt_result_wrap_syntax in @@ -513,6 +515,9 @@ module Delegate = struct let staking_balance ctxt pkh = Delegate_services.staking_balance rpc_ctxt ctxt pkh + let unstaked_frozen_deposits ctxt pkh = + Plugin.RPC.Delegates.unstaked_frozen_deposits rpc_ctxt ctxt pkh + let staking_denominator ctxt pkh = let open Lwt_result_syntax in let+ pseudotokens = @@ -531,14 +536,11 @@ module Delegate = struct let participation ctxt pkh = Delegate_services.participation rpc_ctxt ctxt pkh - let is_forbidden ?policy ctxt pkh = - let open Lwt_result_syntax in - let* ctxt = get_alpha_ctxt ?policy ctxt in - return (Delegate.is_forbidden_delegate ctxt pkh) + let is_forbidden ctxt pkh = Plugin.RPC.Staking.is_forbidden rpc_ctxt ctxt pkh - let stake_for_cycle ?policy ctxt cycle pkh = + let stake_for_cycle ctxt cycle pkh = let open Lwt_result_wrap_syntax in - let* alpha_ctxt = get_alpha_ctxt ?policy ctxt in + let* alpha_ctxt = get_alpha_ctxt ctxt in let*@ stakes = Protocol.Alpha_context.Stake_distribution.Internal_for_tests .get_selected_distribution @@ -745,7 +747,7 @@ let init_with_parameters1 = init_with_parameters_gen T1 let init_with_parameters2 = init_with_parameters_gen T2 -let default_raw_context () = +let raw_context_from_constants constants = let open Lwt_result_wrap_syntax in let open Tezos_protocol_019_PtParisB_parameters in let initial_account = Account.new_account () in @@ -754,7 +756,6 @@ let default_raw_context () = ~balance:(Tez.of_mutez_exn 100_000_000_000L) initial_account in - let* constants, _, _ = Block.prepare_initial_context_params () in let parameters = Default_parameters.parameters_of_constants ~bootstrap_accounts:[bootstrap_accounts] @@ -787,3 +788,8 @@ let default_raw_context () = ~typecheck_smart_rollup in return e + +let default_raw_context () = + let open Lwt_result_wrap_syntax in + let* constants, _, _ = Block.prepare_initial_context_params () in + raw_context_from_constants constants diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/context.mli b/src/proto_019_PtParisB/lib_protocol/test/helpers/context.mli index c6593218e140dba410168db0cafcdcfc89e6ba49..3965942511b705efc40311b715b694cfc44fea00 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/context.mli +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/context.mli @@ -30,6 +30,8 @@ open Environment type t = B of Block.t | I of Incremental.t +val get_alpha_ctxt : t -> context tzresult Lwt.t + val branch : t -> Block_hash.t val pred_branch : t -> Block_hash.t @@ -282,6 +284,11 @@ module Delegate : sig val staking_balance : t -> public_key_hash -> Tez.t tzresult Lwt.t + val unstaked_frozen_deposits : + t -> + public_key_hash -> + Protocol.Delegate_services.deposit_per_cycle list tzresult Lwt.t + val staking_denominator : t -> public_key_hash -> Z.t tzresult Lwt.t val frozen_deposits_limit : @@ -297,17 +304,9 @@ module Delegate : sig val participation : t -> public_key_hash -> Delegate.For_RPC.participation_info tzresult Lwt.t - (** This function might begin constructing a block. Use [policy] to - specify a valid baker for the new block (default [By_round 0]) *) - val is_forbidden : - ?policy:Block.baker_policy -> t -> public_key_hash -> bool tzresult Lwt.t + val is_forbidden : t -> public_key_hash -> bool tzresult Lwt.t - val stake_for_cycle : - ?policy:Block.baker_policy -> - t -> - Cycle.t -> - public_key_hash -> - stake tzresult Lwt.t + val stake_for_cycle : t -> Cycle.t -> public_key_hash -> stake tzresult Lwt.t end module Sc_rollup : sig @@ -456,3 +455,8 @@ val init_with_parameters2 : (** [default_raw_context] returns a [Raw_context.t] for use in tests below [Alpha_context] *) val default_raw_context : unit -> Raw_context.t tzresult Lwt.t + +(** [raw_context_from_constants] returns a [Raw_context.t] for use in tests + below [Alpha_context] *) +val raw_context_from_constants : + Constants.Parametric.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/contract_helpers.ml index 32043ee302b722a8a043b7da9582ab639ffbced5..56b5cb458694fa135908ef56168b933479f89a24 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/contract_helpers.ml @@ -28,9 +28,11 @@ open Alpha_context (** Initializes 2 addresses to do only operations plus one that will be used to bake. *) -let init () = +let init ?hard_gas_limit_per_block () = let open Lwt_result_syntax in - let+ b, (src0, src1, src2) = Context.init3 ~consensus_threshold:0 () in + let+ b, (src0, src1, src2) = + Context.init3 ?hard_gas_limit_per_block ~consensus_threshold:0 () + in let baker = match src0 with Implicit v -> v | Originated _ -> assert false in @@ -53,7 +55,7 @@ let originate_contract_hash file storage src b baker = let open Lwt_result_syntax in let script = load_script ~storage file in let* operation, dst = - Op.contract_origination_hash (B b) src ~fee:(Test_tez.of_int 10) ~script + Op.contract_origination_hash (B b) src ~fee:(Tez_helpers.of_int 10) ~script in let* incr = Incremental.begin_construction ~policy:Block.(By_account baker) b @@ -136,7 +138,7 @@ let originate_contract_from_string_hash ~script ~storage ~source_contract ~baker Op.contract_origination_hash (B block) source_contract - ~fee:(Test_tez.of_int 10) + ~fee:(Tez_helpers.of_int 10) ~script in let* incr = diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/cpmm_logic.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/cpmm_logic.ml index a1d4d8027c5808afbd02a62372fede6e8adc33f9..3b50ed17945efda4606bee35007cec750744a914 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/cpmm_logic.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/cpmm_logic.ml @@ -27,7 +27,7 @@ open Protocol open Alpha_context (** This is a simulation of the CPMM contract, as implemented in mligo - in [src/proto_alpha/lib_protocol/contracts/cpmm.mligo]. The + in [src/proto_019_PtParisB/lib_protocol/contracts/cpmm.mligo]. The interested reader should look for comments in this file to gain a better understanding of the contract logic. *) module Simulate_raw = struct diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/dal_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/dal_helpers.ml index 09dffdb09ad02e5cf83044c9d3a45922d2f08ff7..847bbc2046f9f403f0eaa733421491da4767f028 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/dal_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/dal_helpers.ml @@ -46,13 +46,15 @@ let () = (function Test_failure e -> Some e | _ -> None) (fun e -> Test_failure e) +let dal_prover_srs = + lazy + (Cryptobox.Config.init_prover_dal + ~find_srs_files:Tezos_base.Dal_srs.find_trusted_setup_files + Cryptobox.Config.default) + let mk_cryptobox dal_params = let open Lwt_result_syntax in - let* () = - Cryptobox.Config.init_prover_dal - ~find_srs_files:Tezos_base.Dal_srs.find_trusted_setup_files - Cryptobox.Config.default - in + let* () = Lazy.force dal_prover_srs in match Cryptobox.make dal_params with | Ok dal -> return dal | Error (`Fail s) -> fail [Test_failure s] diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/dune b/src/proto_019_PtParisB/lib_protocol/test/helpers/dune index 6167b19c955f45ab0831a4541bf0a02b60f43643..cb945491ad2677b5dbfe2760e712deb9d5f1c2bd 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/dune +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/dune @@ -7,9 +7,8 @@ (instrumentation (backend bisect_ppx)) (libraries tezt.core - octez-alcotezt + tezt-tezos tezt - octez-libs.base-test-helpers qcheck-alcotest octez-libs.test-helpers octez-libs.base @@ -28,8 +27,6 @@ (:standard) -open Tezt_core -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base_test_helpers -open Tezos_base.TzPervasives -open Tezos_micheline -open Tezos_stdlib_unix diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/error_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/error_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..34c08aecfe95fea8aa40a3339d7ea2bbd4a1c97c --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/error_helpers.ml @@ -0,0 +1,59 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Helpers to check expected errors. *) + +open Protocol +open Alpha_context +open Validate_errors.Manager + +(** Identifies the [Inconsistent_sources] error. *) +let check_inconsistent_sources ~first_source:_ ~source:_ = function + | [Inconsistent_sources] -> true + | _ -> false + +(** To be used as the [expect_failure] argument of + {!Incremental.add_operation} when expecting the + [Inconsistent_sources] error. *) +let expect_inconsistent_sources ~loc ~first_source ~source errs = + Assert.expect_error + ~loc + errs + (check_inconsistent_sources ~first_source ~source) + +(** Identifies the [Inconsistent_counters] error. *) +let check_inconsistent_counters ~source:_ ~previous_counter:_ ~counter:_ = + function + | [Inconsistent_counters] -> true + | _ -> false + +(** To be used as the [expect_failure] argument of + {!Incremental.add_operation} when expecting the + [Inconsistent_counters] error. *) +let expect_inconsistent_counters ~loc ~source ~previous_counter ~counter errs = + Assert.expect_error + ~loc + errs + (check_inconsistent_counters ~source ~previous_counter ~counter) + +(** Same as {!expect_inconsistent_counters} but with [int] arguments + for counters. *) +let expect_inconsistent_counters_int ~loc ~source ~previous_counter ~counter + errs = + let counter = Manager_counter.Internal_for_tests.of_int counter in + let previous_counter = + Manager_counter.Internal_for_tests.of_int previous_counter + in + expect_inconsistent_counters ~loc ~source ~previous_counter ~counter errs + +(** To be used as the [expect_failure] argument of + {!Incremental.add_operation} when expecting the + [Incorrect_reveal_position] error. *) +let expect_incorrect_reveal_position ~loc errs = + Assert.expect_error ~loc errs (function + | [Incorrect_reveal_position] -> true + | _ -> false) diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/log_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/log_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..af59306b9dd1b977f95dbf953fd86f700d13236b --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/log_helpers.ml @@ -0,0 +1,22 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +let begin_end_color = Log.Color.(BG.bright_white ++ FG.black ++ bold) + +let time_color = Log.Color.FG.yellow + +let action_color = Log.Color.FG.green + +let event_color = Log.Color.FG.blue + +let warning_color = Log.Color.FG.red + +let low_debug_color = Log.Color.FG.gray + +let assert_block_color = Log.Color.(BG.blue ++ FG.gray) + +let tez_color = Log.Color.FG.bright_white diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/op.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/op.ml index b1ee1cdb04410c0fe5f4913c2888f3677f8a2e1f..7a625f8c4bc8cea30a545be9c7fc5d3ac36e0692 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/op.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/op.ml @@ -795,7 +795,7 @@ let dummy_script = storage = lazy_expr (strip_locations (Prim ((), D_Unit, [], []))); } -let dummy_script_cost = Test_tez.of_mutez_exn 9_500L +let dummy_script_cost = Tez_helpers.of_mutez 9_500L let transfer_ticket ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt ~(source : Contract.t) ~contents ~ty ~ticketer ~amount ~destination diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/sapling_helpers.ml index 5e058258d5e1c46f5b5f4d86d043b1b9ad1f2e9c..25100ebcb4062b936fc86a98c240372f40634171 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/sapling_helpers.ml @@ -417,9 +417,9 @@ module Interpreter_helpers = struct let transac_and_sync ~memo_size block parameters amount src dst baker = let open Lwt_result_syntax in let amount_tez = - Test_tez.(Alpha_context.Tez.one_mutez *! Int64.of_int amount) + Tez_helpers.(Alpha_context.Tez.one_mutez *! Int64.of_int amount) in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let* operation = Op.transaction ~gas_limit:Max diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario.ml new file mode 100644 index 0000000000000000000000000000000000000000..38a2e0be669aaa7baeb792bd7dd52d8ce26ca2ca --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario.ml @@ -0,0 +1,17 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module centralises all modules related to [Scenario] writing and + execution. Most scenario tests would use most if not all of them, so + they only need to [open Scenario]. *) + +include Scenario_base +include Scenario_op +include Scenario_dsl +include Scenario_begin +include Scenario_constants +include Scenario_bake diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_bake.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_bake.ml new file mode 100644 index 0000000000000000000000000000000000000000..356b65fb4e86566241bba590167acb53458b05ef --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_bake.ml @@ -0,0 +1,555 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open State_account +open State +open Scenario_dsl +open Log_helpers +open Scenario_base + +(** Applies when baking the last block of a cycle *) +let apply_end_cycle current_cycle previous_block block state : + State.t tzresult Lwt.t = + let open Lwt_result_wrap_syntax in + Log.debug ~color:time_color "Ending cycle %a" Cycle.pp current_cycle ; + (* Apply all slashes *) + let* state = + Slashing_helpers.apply_all_slashes_at_cycle_end + current_cycle + previous_block + state + in + (* Apply autostaking *) + let* state = State_ai_flags.Autostake.run_at_cycle_end block state in + (* Sets initial frozen for future cycle *) + let* state = update_map_es ~f:(compute_future_frozen_rights block) state in + (* Apply parameter changes *) + let state, param_requests = + List.fold_left + (fun (state, remaining_requests) (name, params, wait) -> + if wait > 0 then (state, (name, params, wait - 1) :: remaining_requests) + else + let src = find_account name state in + let state = + update_account name {src with parameters = params} state + in + (state, remaining_requests)) + (state, []) + state.param_requests + in + return {state with param_requests} + +(** Applies when baking the first block of a cycle. + Technically nothing special happens, but we need to update the unslashable unstakes + since it's done lazily *) +let apply_new_cycle new_cycle state : State.t = + apply_unslashable_for_all new_cycle state + +(** After baking and applying rewards in state *) +let check_all_balances block state : unit tzresult Lwt.t = + let open Lwt_result_syntax in + let State.{account_map; total_supply; _} = state in + let* actual_total_supply = Context.get_total_supply (B block) in + let*! r1 = + String.Map.fold_s + (fun name account acc -> + log_debug_balance name account_map ; + let* () = log_debug_rpc_balance name (Implicit account.pkh) block in + let*! r = + assert_balance_check ~loc:__LOC__ (B block) name account_map + in + Assert.join_errors r acc) + account_map + Result.return_unit + in + let*! r2 = + Assert.equal + ~loc:__LOC__ + Tez.equal + "Total supplies do not match" + Tez.pp + actual_total_supply + total_supply + in + Assert.join_errors r1 r2 + +(** Misc checks at block end *) +let check_misc block state : unit tzresult Lwt.t = + let open Lwt_result_syntax in + let State.{account_map; _} = state in + String.Map.fold_s + (fun name account acc -> + match account.delegate with + | Some x when String.equal x name -> + let ufd_state = + List.map + (fun ({cycle; current; _} : Unstaked_frozen.r) -> + (cycle, current)) + account.unstaked_frozen + in + let ufnlz_state = + Unstaked_finalizable.total account.unstaked_finalizable + in + let ufd_state_map = + List.fold_left + (fun acc (cycle, v) -> CycleMap.add cycle v acc) + CycleMap.empty + ufd_state + in + let* u_rpc = + Context.Delegate.unstaked_frozen_deposits (B block) account.pkh + in + let u_rpc = + List.map + (fun ({cycle; deposit} : + Protocol.Delegate_services.deposit_per_cycle) -> + (cycle, deposit)) + u_rpc + in + let finalizable_cycle = + Cycle.sub + (Block.current_cycle block) + (state.State.constants.consensus_rights_delay + 2) + in + let ufnlz_rpc, ufd_rpc = + match finalizable_cycle with + | None -> (Tez.zero, u_rpc) + | Some finalizable_cycle -> ( + match + List.partition + (fun (cycle, _) -> Cycle.equal cycle finalizable_cycle) + u_rpc + with + | [], l -> (Tez.zero, l) + | [(_, s)], l -> (s, l) + | _ -> assert false) + in + let*! r1 = Assert.equal_tez ~loc:__LOC__ ufnlz_rpc ufnlz_state in + let*! r2 = + List.fold_left + (fun acc (cycle, v) -> + let state_val = + CycleMap.find cycle ufd_state_map + |> Option.value ~default:Tez.zero + in + let*! r = Assert.equal_tez ~loc:__LOC__ v state_val in + let*! acc in + Assert.join_errors r acc) + return_unit + ufd_rpc + in + let*! r = Assert.join_errors r1 r2 in + Assert.join_errors r acc + | _ -> Lwt.return acc) + account_map + Result.return_unit + +let check_issuance_rpc block : unit tzresult Lwt.t = + let open Lwt_result_syntax in + (* We assume one block per minute *) + let* rewards_per_block = Context.get_issuance_per_minute (B block) in + let* total_supply = Context.get_total_supply (B block) in + let* expected_issuance = Context.get_ai_expected_issuance (B block) in + let* () = + match expected_issuance with + | ei :: _ -> + (* We assume only the fixed portion is issued *) + Assert.equal_tez + ~loc:__LOC__ + rewards_per_block + ei.baking_reward_fixed_portion + | _ -> failwith "expected_issuance rpc: unexpected value" + in + let* yearly_rate = Context.get_ai_current_yearly_rate (B block) in + let* yearly_rate_exact = Context.get_ai_current_yearly_rate_exact (B block) in + let yr = float_of_string yearly_rate in + let yre = Q.to_float yearly_rate_exact in + (* Precision for yearly rate is 0.001 *) + let* () = + Assert.equal + ~loc:__LOC__ + (fun x y -> Float.(abs (x -. y) <= 0.001)) + "Yearly rate (float)" + Format.pp_print_float + yr + yre + in + (* Divided by 525_600 minutes per year, x100 because rpc returns a pct *) + let issuance_from_rate = + Tez.( + mul_q total_supply Q.(div yearly_rate_exact ~$525_600_00) + |> of_q ~round:`Down) + in + let* () = + Assert.equal + ~loc:__LOC__ + Tez.equal + "Issuance" + Tez.pp + rewards_per_block + issuance_from_rate + in + return_unit + +let attest_all_ = + let open Lwt_result_syntax in + fun (block, state) -> + let dlgs = + String.Map.bindings state.State.account_map + |> List.filter (fun (name, acc) -> + match acc.delegate with + | Some x -> String.equal x name + | None -> false) + |> List.map snd + in + let* ops = + List.map_es (fun dlg -> Op.attestation ~delegate:dlg.pkh block) dlgs + in + let state = State.add_pending_operations ops state in + return (block, state) + +(* Does not produce a new block *) +let attest_all = exec attest_all_ + +(** Bake a block, with the given baker and the given operations. *) +let bake ?baker : t -> t tzresult Lwt.t = + fun (block, state) -> + let open Lwt_result_wrap_syntax in + let previous_block = block in + let policy = + match baker with + | None -> state.baking_policy + | Some baker -> + let {pkh; _} = + try State.find_account baker state + with Not_found -> + Log.info + ~color:warning_color + "Invalid baker: %s not found. Aborting" + baker ; + assert false + in + Some (Block.By_account pkh) + in + let* baker, _, _, _ = Block.get_next_baker ?policy block in + let baker_name, {contract = baker_contract; _} = + State.find_account_from_pkh baker state + in + let current_cycle = Block.current_cycle block in + let* level = Plugin.RPC.current_level Block.rpc_ctxt block in + assert (Protocol.Alpha_context.Cycle.(level.cycle = Block.current_cycle block)) ; + Log.info + ~color:time_color + "Baking level %d (cycle %ld) with %s" + (Int32.to_int (Int32.succ Block.(block.header.shell.level))) + (Protocol.Alpha_context.Cycle.to_int32 level.cycle) + baker_name ; + let adaptive_issuance_vote = + if state.force_ai_vote_yes then + Protocol.Alpha_context.Per_block_votes.Per_block_vote_on + else Per_block_vote_pass + in + let* () = check_issuance_rpc block in + let state, operations = State.pop_pending_operations state in + let* block, state = + let* block', _metadata = + Block.bake_with_metadata ?policy ~adaptive_issuance_vote ~operations block + in + if state.burn_rewards then + (* Incremental mode *) + let* i = + Incremental.begin_construction ?policy ~adaptive_issuance_vote block + in + let* block_rewards = Context.get_issuance_per_minute (B block') in + let ctxt = Incremental.alpha_ctxt i in + let*@ context, _ = + Protocol.Alpha_context.Token.transfer + ctxt + (`Contract baker_contract) + `Burned + block_rewards + in + let i = Incremental.set_alpha_ctxt i context in + let* i = List.fold_left_es Incremental.add_operation i operations in + let* block = Incremental.finalize_block i in + let state = State.apply_burn block_rewards baker_name state in + return (block, state) + else return (block', state) + in + let baker_acc = State.find_account baker_name state in + (* update baker and attesters activity *) + let update_activity delegate_account = + Account_helpers.update_activity + delegate_account + state.constants + ~level:block.header.shell.level + (Block.current_cycle block) + in + let* attesters = + let open Tezos_raw_protocol_019_PtParisB.Alpha_context in + let* ctxt = Context.get_alpha_ctxt (B previous_block) in + List.filter_map_es + (fun op -> + let ({protocol_data = Operation_data protocol_data; _} + : packed_operation) = + op + in + match protocol_data.contents with + | Single (Attestation {consensus_content; _}) -> + let*@ _, owner = + Stake_distribution.slot_owner + ctxt + (Level.from_raw ctxt consensus_content.level) + consensus_content.slot + in + return_some owner.delegate + | _ -> return_none) + operations + in + let state = + State.update_map + ~f:(fun acc_map -> + let acc_map = + String.Map.add baker_name (update_activity baker_acc) acc_map + in + List.fold_left + (fun acc_map delegate_pkh -> + let delegate_name, delegate_acc = + State.find_account_from_pkh delegate_pkh state + in + String.Map.add delegate_name (update_activity delegate_acc) acc_map) + acc_map + attesters) + state + in + let* state = + State_ai_flags.AI_Activation.check_activation_cycle block state + in + let* state = State.apply_rewards ~baker:baker_name block state in + (* First block of a new cycle *) + let new_current_cycle = Block.current_cycle block in + let* state = + if Protocol.Alpha_context.Cycle.(current_cycle = new_current_cycle) then + return state + else ( + Log.info + ~color:time_color + "Cycle %d" + (Protocol.Alpha_context.Cycle.to_int32 new_current_cycle |> Int32.to_int) ; + return @@ apply_new_cycle new_current_cycle state) + in + (* Dawn of a new cycle *) + let* state = + if not (Block.last_block_of_cycle block) then return state + else apply_end_cycle current_cycle previous_block block state + in + let* () = check_all_balances block state in + let* () = check_misc block state in + let* block, state = + if state.force_attest_all then attest_all_ (block, state) + else return (block, state) + in + return (block, state) + +(** Bake until a cycle is reached, using [bake] instead of [Block.bake] *) +let bake_until_next_cycle : t -> t tzresult Lwt.t = + fun (init_block, init_state) -> + let open Lwt_result_syntax in + let current_cycle = Block.current_cycle init_block in + let rec step (old_block, old_state) = + let step_cycle = Block.current_cycle old_block in + if Protocol.Alpha_context.Cycle.(step_cycle > current_cycle) then + return (old_block, old_state) + else + let* new_block, new_state = bake (old_block, old_state) in + step (new_block, new_state) + in + step (init_block, init_state) + +(** Bake all the remaining blocks of the current cycle *) +let bake_until_dawn_of_next_cycle : t -> t tzresult Lwt.t = + fun (init_block, init_state) -> + let open Lwt_result_syntax in + let current_cycle = Block.current_cycle init_block in + let rec step (old_block, old_state) = + let* new_block, new_state = bake (old_block, old_state) in + let step_cycle = Block.current_cycle new_block in + if Protocol.Alpha_context.Cycle.(step_cycle > current_cycle) then + return (old_block, old_state) + else step (new_block, new_state) + in + step (init_block, init_state) + +(* ======== Operations ======== *) + +(** Bake a single block *) +let next_block = + exec (fun input -> + Log.info ~color:action_color "[Next block]" ; + bake input) + +(** Bake a single block with a specific baker *) +let next_block_with_baker baker = + exec (fun input -> + Log.info ~color:action_color "[Next block (baker %s)]" baker ; + bake ~baker input) + +(** Bake until the end of a cycle *) +let next_cycle_ input = + Log.info ~color:action_color "[Next cycle]" ; + bake_until_next_cycle input + +(** Bake until the end of a cycle *) +let next_cycle = exec next_cycle_ + +(** Executes an operation: f should return a new state and a list of operations, which are then applied *) +let exec_op f = + let open Lwt_result_syntax in + Action + (fun ((block, _state) as input) -> + let* state, ops = f input in + let state = State.add_pending_operations ops state in + return (block, state)) + --> next_block + +(** Waiting functions *) +let wait_n_cycles n = loop n next_cycle + +let wait_n_blocks n = loop n next_block + +let wait_cycle_f_es (condition : t -> t -> bool tzresult Lwt.t) : + (t, t) scenarios = + let open Lwt_result_syntax in + exec (fun init_t -> + let rec bake_while t = + let* b = condition init_t t in + if b then return t + else + let* t = next_cycle_ t in + bake_while t + in + bake_while init_t) + +(** Waits until [condition init_t current_t] is fulfilled. + It is checked on the first block of every cycle. If it returns false, + another cycle is baked, until it succeeds. +*) +let wait_cycle_f (condition : t -> t -> bool) : (t, t) scenarios = + let open Lwt_result_syntax in + let condition a b = return @@ condition a b in + wait_cycle_f_es condition + +(** Wait until we are in a cycle satisfying the given condition. + Fails if AI_activation is requested and AI is not set to be activated in the future. *) +let wait_cycle_until condition = + let to_, done_ = + let rec get_names condition = + match condition with + | `AI_activation -> ("AI activation", "AI activated") + | `AI_activation_with_votes -> + ("AI activation (with votes)", "AI activated") + | `delegate_parameters_activation -> + ("delegate parameters activation", "delegate parameters activated") + | `right_before_delegate_parameters_activation -> + ( "right before delegate parameters activation", + "delegate parameters will activate next cycle" ) + | `And (cond1, cond2) -> + let to1, done1 = get_names cond1 in + let to2, done2 = get_names cond2 in + (to1 ^ " and " ^ to2, done1 ^ " and " ^ done2) + in + get_names condition + in + let condition (init_block, init_state) = + let rec stopper condition = + match condition with + | `AI_activation -> ( + fun (block, _state) -> + (* Expects the launch cycle to be already set *) + match init_state.State.ai_activation_cycle with + | Some launch_cycle -> + let current_cycle = Block.current_cycle block in + Cycle.(current_cycle >= launch_cycle) + | _ -> + Log.error + "wait_cycle_until `AI_activation: launch cycle not found, \ + aborting." ; + assert false) + | `AI_activation_with_votes -> + fun (block, state) -> + if State_ai_flags.AI_Activation.enabled init_state then + match state.State.ai_activation_cycle with + (* Since AI_activation is enabled, we expect the activation + cycle to be set eventually *) + | Some launch_cycle -> + let current_cycle = Block.current_cycle block in + Cycle.(current_cycle >= launch_cycle) + | _ -> false + else ( + Log.error + "wait_cycle_until `AI_activation_with_votes: AI cannot \ + activate with the current protocol parameters, aborting." ; + assert false) + | `delegate_parameters_activation -> + fun (block, _state) -> + let init_cycle = Block.current_cycle init_block in + let cycles_to_wait = + (* Delegate parameters wait for at least + [delegate_parameters_activation_delay] **full + cycles** to activate, so we need to add 1 to the + number of cycles to wait. *) + init_state.constants.delegate_parameters_activation_delay + 1 + in + Cycle.(Block.current_cycle block >= add init_cycle cycles_to_wait) + | `right_before_delegate_parameters_activation -> + fun (block, _state) -> + let init_cycle = Block.current_cycle init_block in + let cycles_to_wait = + init_state.constants.delegate_parameters_activation_delay + in + Cycle.(Block.current_cycle block >= add init_cycle cycles_to_wait) + | `And (cond1, cond2) -> + let stop1 = stopper cond1 in + let stop2 = stopper cond2 in + fun (block, state) -> + let b1 = stop1 (block, state) in + let b2 = stop2 (block, state) in + b1 && b2 + in + stopper condition + in + log ~color:time_color "Fast forward to %s" to_ + --> wait_cycle_f condition + --> log ~color:event_color "%s" done_ + +(** Wait until AI activates. + Fails if AI is not set to be activated in the future. *) +let wait_ai_activation = + wait_cycle_until `AI_activation + --> exec_unit (fun (block, state) -> + assert (State_ai_flags.AI.enabled block state) ; + Lwt_result_syntax.return_unit) + +(** wait delegate_parameters_activation_delay cycles *) +let wait_delegate_parameters_activation = + wait_cycle_until `delegate_parameters_activation + +let wait_n_cycles_f_es (n_cycles : t -> int tzresult Lwt.t) = + let open Lwt_result_syntax in + let condition ((init_block, _init_state) as t_init) + ((current_block, _current_state) as _t_current) = + let* n = n_cycles t_init in + let init_cycle = Block.current_cycle init_block in + let current_cycle = Block.current_cycle current_block in + return Cycle.(current_cycle >= add init_cycle n) + in + wait_cycle_f_es condition + +let wait_n_cycles_f (n_cycles : t -> int) = + let open Lwt_result_syntax in + let n_cycles n = return @@ n_cycles n in + wait_n_cycles_f_es n_cycles diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_base.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_base.ml new file mode 100644 index 0000000000000000000000000000000000000000..ddcbe5f972829b65d90323b2cf3a9ca6341aa159 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_base.ml @@ -0,0 +1,268 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module gathers the basic operations used in test scenarios. This + includes starting a scenario, baking, checking and manipulating the state, + and various wait functions *) + +open State_account +open State +open Scenario_dsl +open Log_helpers + +(** For [assert_failure], when expected error does not match the actual error. *) +type error += Unexpected_error + +(** For [assert_failure], when scenario actually succeeds when expected to fail. *) +type error += Unexpected_success + +(** Usual threaded state for the tests. Contains the current block, pending operations + and the known [State.t] *) +type t = Block.t * State.t + +let log ?(level = Cli.Logs.Info) ?color format = + Format.kasprintf + (fun s -> + exec_unit (fun _ -> + Log.log ~level ?color "%s" s ; + Lwt_result_syntax.return_unit)) + format + +(* ======== State updates ======== *) + +(** Sets the de facto baker for all future blocks *) +let set_baker baker : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (_block, state) -> + let {pkh; _} = State.find_account baker state in + return {state with State.baking_policy = Some (Block.By_account pkh)}) + +(** Exclude a list of delegates from baking *) +let exclude_bakers bakers : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (_block, state) -> + let bakers_pkh = + List.map (fun baker -> (State.find_account baker state).pkh) bakers + in + let log_list = + List.combine_drop bakers bakers_pkh + |> List.map (fun (name, pkh) -> + Format.asprintf "%s(%a)" name Signature.Public_key_hash.pp pkh) + in + Log.log + ~level:Cli.Logs.Info + ~color:event_color + "Excluding bakers: [ %s ]" + (String.concat ", " log_list) ; + return + {state with State.baking_policy = Some (Block.Excluding bakers_pkh)}) + +(** Unsets the baking policy, it returns to default ([By_round 0]) *) +let unset_baking_policy : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (_block, state) -> + return {state with State.baking_policy = None}) + +(** Creates a snapshot of the current balances for the given account names. + Can be used to check that balances at point A and B in the execution of a test + are the same (either nothing happened, or a succession of actions resulted in + getting the same values as before *) +let snapshot_balances snap_name names_list : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (_block, state) -> + Log.debug + ~color:low_debug_color + "Snapshoting balances as \"%s\"" + snap_name ; + let balances = + List.map + (fun name -> (name, balance_of_account name state.State.account_map)) + names_list + in + let snapshot_balances = + String.Map.add snap_name balances state.snapshot_balances + in + return {state with snapshot_balances}) + +(** Check balances against a previously defined snapshot *) +let check_snapshot_balances + ?(f = + fun ~name ~old_balance ~new_balance -> + assert_balance_equal ~loc:__LOC__ name old_balance new_balance) + snap_name : (t, t) scenarios = + let open Lwt_result_syntax in + exec_unit (fun (_block, state) -> + Log.debug + ~color:low_debug_color + "Checking evolution of balances between \"%s\" and now" + snap_name ; + let snapshot_balances = + String.Map.find snap_name state.State.snapshot_balances + in + match snapshot_balances with + | None -> + Log.debug + ~color:warning_color + "\"%s\" snapshot not found..." + snap_name ; + return_unit + | Some snapshot_balances -> + let* () = + List.iter_es + (fun (name, old_balance) -> + let new_balance = + balance_of_account name state.State.account_map + in + f ~name ~old_balance ~new_balance) + snapshot_balances + in + return_unit) + +(** Save the current issuance rate for future use *) +let save_current_rate : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (block, state) -> + let* rate = Context.get_ai_current_yearly_rate_exact (B block) in + return {state with State.saved_rate = Some rate}) + +(** Check that [f saved_rate current_rate] is true. [f] is typically a comparison function *) +let check_rate_evolution (f : Q.t -> Q.t -> bool) : (t, t) scenarios = + let open Lwt_result_syntax in + exec_unit (fun (block, state) -> + let* new_rate = Context.get_ai_current_yearly_rate_exact (B block) in + let previous_rate = state.State.saved_rate in + match previous_rate with + | None -> failwith "check_rate_evolution: no rate previously saved" + | Some previous_rate -> + if f previous_rate new_rate then return_unit + else + failwith + "check_rate_evolution: assertion failed@.previous rate: %a@.new \ + rate: %a" + Q.pp_print + previous_rate + Q.pp_print + new_rate) + +(* ======== Misc functions ========*) + +let check_failure_aux ?(loc = __LOC__) ?expected_error : + ('a -> 'b tzresult Lwt.t) -> 'a -> 'a tzresult Lwt.t = + let open Lwt_result_syntax in + fun f input -> + Log.info ~color:assert_block_color "Entering failing scenario..." ; + let*! output = f input in + match output with + | Ok _ -> + Log.info "%s: Unexpected success@." loc ; + tzfail Unexpected_success + | Error e -> ( + match expected_error with + | None -> + Log.info ~color:assert_block_color "Rollback" ; + return input + | Some exp_e -> + let exp_e = exp_e input in + if e = exp_e then ( + Log.info ~color:assert_block_color "Rollback" ; + return input) + else ( + Log.info + "%s: Unexpected error:@.%a@.Expected:@.%a@." + loc + (Format.pp_print_list pp) + e + (Format.pp_print_list pp) + exp_e ; + tzfail Unexpected_error)) + +let check_fail_and_rollback ?(loc = __LOC__) ?expected_error : + ('a, 'b) single_scenario -> 'a -> 'a tzresult Lwt.t = + fun sc input -> check_failure_aux ~loc ?expected_error (run_scenario sc) input + +(** Useful function to test expected failures: runs the given branch until it fails, + then rollbacks to before execution. Fails if the given branch Succeeds *) +let assert_failure ?(loc = __LOC__) ?expected_error : + ('a, 'b) scenarios -> ('a, 'a) scenarios = + fun scenarios -> + match unfold_scenarios scenarios with + | [] -> Empty + | [(sc, _, _)] -> exec (check_fail_and_rollback ~loc ?expected_error sc) + | _ -> + exec (fun _ -> + failwith "%s: Error: assert_failure used with branching scenario" loc) + +(** Check a scenario does not fail, and rolls back to before the assert *) +let assert_success ?(loc = __LOC__) : ('a, 'b) scenarios -> ('a, 'a) scenarios = + fun scenarios -> + match unfold_scenarios scenarios with + | [] -> Empty + | [(sc, _, _)] -> + exec + (let open Lwt_result_syntax in + fun input -> + let* _ = run_scenario sc input in + return input) + | _ -> + exec (fun _ -> + failwith "%s: Error: assert_success used with branching scenario" loc) + +(** Loop *) +let rec loop n : ('a, 'a) scenarios -> ('a, 'a) scenarios = + fun scenario -> + (* If branching scenarios with k branches, returns a scenario with k^n branches *) + if n = 0 then Empty + else if n = 1 then scenario + else loop (n - 1) scenario --> scenario + +let rec loop_action n : ('a -> 'a tzresult Lwt.t) -> ('a, 'a) scenarios = + fun f -> + if n = 0 then Empty + else if n = 1 then exec f + else loop_action (n - 1) f --> exec f + +(** Check a specific balance field for a specific account is equal to a specific amount *) +let check_balance_field src_name field amount : (t, t) scenarios = + let open Lwt_result_syntax in + let check = Assert.equal_tez ~loc:__LOC__ amount in + let check' a = check (Partial_tez.to_tez ~round:`Down a) in + exec_unit (fun (block, state) -> + let src = State.find_account src_name state in + let src_balance, src_total = + balance_and_total_balance_of_account src_name state.account_map + in + let* rpc_balance, rpc_total = + get_balance_from_context (B block) src.contract + in + let* () = + match field with + | `Liquid -> + let* () = check rpc_balance.liquid_b in + check src_balance.liquid_b + | `Bonds -> + let* () = check rpc_balance.bonds_b in + check src_balance.bonds_b + | `Staked -> + let* () = check' rpc_balance.staked_b in + check' src_balance.staked_b + | `Unstaked_frozen_total -> + let* () = check rpc_balance.unstaked_frozen_b in + check src_balance.unstaked_frozen_b + | `Unstaked_finalizable -> + let* () = check rpc_balance.unstaked_finalizable_b in + check src_balance.unstaked_finalizable_b + | `Total -> + let* () = check rpc_total in + check src_total + in + return_unit) + +let check_balance_fields src_name ~liquid ~staked + ?(unstaked_frozen_total = Tez.zero) () = + check_balance_field src_name `Staked staked + --> check_balance_field src_name `Liquid liquid + --> check_balance_field src_name `Unstaked_frozen_total unstaked_frozen_total diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_begin.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_begin.ml new file mode 100644 index 0000000000000000000000000000000000000000..6ea7a016fc18f2516429da266f3f26066d68ce11 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_begin.ml @@ -0,0 +1,191 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open State_account +open Scenario_dsl +open Scenario_bake +open Scenario_base +open Log_helpers +open Adaptive_issuance_helpers +open Scenario_constants + +(** Returns when the number of bootstrap accounts created by [Context.init_n n] is not equal to [n] *) +type error += Inconsistent_number_of_bootstrap_accounts + +type starter_constants = Mainnet | Sandbox | Test + +let start ~(constants : starter_constants) : (unit, constants) scenarios = + let constants, name = + match constants with + | Mainnet -> (Default_parameters.constants_mainnet, "mainnet") + | Sandbox -> (Default_parameters.constants_sandbox, "sandbox") + | Test -> (Default_parameters.constants_test, "test") + in + Action + (fun () -> + Log.info ~color:begin_end_color "-- Begin test --" ; + Log.info "Loading constants_%s." name ; + Lwt_result_syntax.return constants) + +let start_with ~(constants : constants) : (unit, constants) scenarios = + Action + (fun () -> + Log.info ~color:begin_end_color "-- Begin test --" ; + Log.info "Loading custom constants." ; + Lwt_result_syntax.return constants) + +let start_with_list ~(constants : (string * constants) list) : + (unit, constants) scenarios = + match constants with + | [] -> + Stdlib.failwith + (Format.asprintf "%s: Cannot build scenarios from empty list" __LOC__) + | _ -> fold_tag (fun constants -> start_with ~constants) constants + +let activate_ai mode = + match mode with + | `Force -> + log ~color:event_color "Forcing AI activation at initial cycle" + --> set S.Adaptive_issuance.force_activation true + | `Zero_threshold -> + (* Requires to wait until AI is activated *) + log ~color:event_color "Setting ai vote threshold to 0" + --> set S.Adaptive_issuance.force_activation false + --> set S.Adaptive_issuance.launch_ema_threshold 0l + | `With_vote_threshold t -> + (* Requires to wait for the votes to pass the threshold, then + wait some more before AI is activated *) + log ~color:event_color "Setting ai vote threshold to %ld" t + --> set S.Adaptive_issuance.force_activation false + --> set S.Adaptive_issuance.activation_vote_enable true + --> set S.Adaptive_issuance.launch_ema_threshold t + | `Force_and_vote_with_threshold t -> + (* Force should have priority on the vote *) + log + ~color:event_color + "Forcing AI activation at initial cycle, and setting ai vote threshold \ + to %ld" + t + --> set S.Adaptive_issuance.force_activation true + --> set S.Adaptive_issuance.activation_vote_enable true + --> set S.Adaptive_issuance.launch_ema_threshold t + | `No -> + (* AI cannot be activated. *) + log ~color:event_color "Setting AI as impossible to activate" + --> set + S.Adaptive_issuance.launch_ema_threshold + (Int32.succ + Protocol.Per_block_votes_repr.Internal_for_tests.ema_max) + --> set S.Adaptive_issuance.force_activation false + --> set S.Adaptive_issuance.activation_vote_enable false + +(** Initializes the constants for testing, with well chosen default values. + Recommended over [start] or [start_with] *) +let init_constants ?(default = Test) ?(reward_per_block = 0L) + ?(deactivate_dynamic = false) ?blocks_per_cycle + ?delegate_parameters_activation_delay () = + let base_total_issued_per_minute = Tez.of_mutez reward_per_block in + start ~constants:default + --> (* default for tests: 12 *) + set_opt S.blocks_per_cycle blocks_per_cycle + --> set_opt + S.delegate_parameters_activation_delay + delegate_parameters_activation_delay + --> set + S.issuance_weights + { + base_total_issued_per_minute; + baking_reward_fixed_portion_weight = 1; + baking_reward_bonus_weight = 0; + attesting_reward_weight = 0; + seed_nonce_revelation_tip_weight = 0; + vdf_revelation_tip_weight = 0; + } + --> set S.liquidity_baking_subsidy Tez.zero + --> set S.minimal_block_delay Protocol.Alpha_context.Period.one_minute + --> set S.cost_per_byte Tez.zero + --> set S.consensus_threshold 0 + --> (if deactivate_dynamic then + set + S.Adaptive_issuance.Adaptive_rewards_params.max_bonus + (Protocol.Issuance_bonus_repr.max_bonus_parameter_of_Q_exn Q.zero) + else Empty) + --> set S.Adaptive_issuance.ns_enable false + +(** Initialize the test, given some initial parameters *) +let begin_test ?(burn_rewards = false) ?(force_attest_all = false) + delegates_name_list : (constants, t) scenarios = + exec (fun (constants : constants) -> + let open Lwt_result_syntax in + let bootstrap = "__bootstrap__" in + let delegates_name_list = bootstrap :: delegates_name_list in + (* Override threshold value if activate *) + let n = List.length delegates_name_list in + let* block, delegates = Context.init_with_constants_n constants n in + let*? init_level = Context.get_level (B block) in + let init_staked = Tez.of_mutez 200_000_000_000L in + let*? account_map = + List.fold_left2 + ~when_different_lengths:[Inconsistent_number_of_bootstrap_accounts] + (fun account_map name contract -> + let liquid = Tez.(Account.default_initial_balance -! init_staked) in + let frozen_deposits = Frozen_tez.init init_staked name name in + let frozen_rights = + List.fold_left + (fun map cycle -> CycleMap.add cycle init_staked map) + CycleMap.empty + Cycle.(root ---> add root constants.consensus_rights_delay) + in + let pkh = Context.Contract.pkh contract in + let account = + init_account + ~delegate:name + ~pkh + ~contract + ~parameters:default_params + ~liquid + ~frozen_deposits + ~frozen_rights + () + in + let account_map = String.Map.add name account account_map in + let balance, total_balance = + balance_and_total_balance_of_account name account_map + in + Log.debug "Initial balance for %s:\n%a" name balance_pp balance ; + Log.debug "Initial total balance: %a" Tez.pp total_balance ; + account_map) + String.Map.empty + delegates_name_list + delegates + in + let* total_supply = Context.get_total_supply (B block) in + let state = + State. + { + account_map; + total_supply; + constants; + param_requests = []; + force_ai_vote_yes = true; + baking_policy = None; + last_level_rewards = init_level; + snapshot_balances = String.Map.empty; + saved_rate = None; + burn_rewards; + pending_operations = []; + pending_slashes = []; + double_signings = []; + ai_activation_cycle = None; + force_attest_all; + } + in + let* () = check_all_balances block state in + let* state = + State_ai_flags.AI_Activation.check_activation_cycle block state + in + return (block, state)) diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_constants.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_constants.ml new file mode 100644 index 0000000000000000000000000000000000000000..019dbb46bd0879280613f298ece7af6d2719bd45 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_constants.ml @@ -0,0 +1,50 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open Scenario_dsl + +type constants = Constants_helpers.t + +(* Not a Set *) +module S = Constants_helpers.Set + +let set : + ('a -> constants -> constants) -> 'a -> (constants, constants) scenarios = + fun f x -> Action (fun csts -> Lwt_result_syntax.return @@ f x csts) + +let set_opt : + ('a -> constants -> constants) -> + 'a option -> + (constants, constants) scenarios = + fun f -> function None -> Empty | Some x -> set f x + +let sets : + ('a -> constants -> constants) -> + (string * 'a) list -> + (constants, constants) scenarios = + fun f -> fold_tag (set f) + +let sets_f : + ('a -> constants -> constants) -> + ('a -> string) -> + 'a list -> + (constants, constants) scenarios = + fun f f_tag -> fold_tag_f (set f) f_tag + +let branch_flag : + (bool -> constants -> constants) -> (constants, constants) scenarios = + fun f -> sets f [("true", true); ("false", false)] + +let branch_flags : + (bool -> constants -> constants) list -> (constants, constants) scenarios = + unfold branch_flag + +let sets_int : + (int -> constants -> constants) -> + int list -> + (constants, constants) scenarios = + fun f -> sets_f f string_of_int diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_dsl.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_dsl.ml new file mode 100644 index 0000000000000000000000000000000000000000..4c85caa403001a7277ef312b1fbb7f9ac2a3af0a --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_dsl.ml @@ -0,0 +1,203 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open Log_helpers + +(** A scenario is a succession of actions. We define a branching path as a way to create multiple tests + from the same point. This allows easy compositionality of behaviors with minimal code sharing. + The [Tag] allows to give meaningful identifiers to the branches. It is good practice to tag each + case in a branch (it's not necessary, but since test names must be unique, at most one branch can + remain unnamed, and even then it can create conflicting names.) + *) +type ('input, 'output) scenarios = + | Action : ('input -> 'output tzresult Lwt.t) -> ('input, 'output) scenarios + | Empty : ('t, 't) scenarios + | Concat : (('a, 'b) scenarios * ('b, 'c) scenarios) -> ('a, 'c) scenarios + | Branch : (('a, 'b) scenarios * ('a, 'b) scenarios) -> ('a, 'b) scenarios + | Tag : (* Name for test branch *) string -> ('t, 't) scenarios + | Slow : (* If in scenario branch, makes the test `Slow *) + ('t, 't) scenarios + +(** Unfolded scenario type *) +type ('input, 'output) single_scenario = + | End_scenario : ('t, 't) single_scenario + | Cons : + (('input -> 't tzresult Lwt.t) * ('t, 'output) single_scenario) + -> ('input, 'output) single_scenario + +let rec cat_ss : + type a b c. + (a, b) single_scenario -> (b, c) single_scenario -> (a, c) single_scenario = + fun a b -> + match a with End_scenario -> b | Cons (act, a') -> Cons (act, cat_ss a' b) + +let combine f l1 l2 = + List.map (fun a -> List.map (fun b -> f a b) l2) l1 |> List.flatten + +let rec unfold_scenarios : + type input output. + (input, output) scenarios -> + ((input, output) single_scenario * string list * bool) list = function + | Slow -> [(End_scenario, [], true)] + | Tag s -> [(End_scenario, [s], false)] + | Empty -> [(End_scenario, [], false)] + | Action a -> [(Cons (a, End_scenario), [], false)] + | Branch (left, right) -> unfold_scenarios left @ unfold_scenarios right + | Concat (left, right) -> + let l = unfold_scenarios left in + let r = unfold_scenarios right in + combine + (fun (sl, tl, bl) (sr, tr, br) -> (cat_ss sl sr, tl @ tr, bl || br)) + l + r + +let rec run_scenario : + type input output. + (input, output) single_scenario -> input -> output tzresult Lwt.t = + let open Lwt_result_syntax in + fun scenario input -> + match scenario with + | End_scenario -> return input + | Cons (action, next) -> + let* result = action input in + run_scenario next result + +type test_closure = string * bool * (Tezt_tezos.Protocol.t -> unit Lwt.t) + +let unfolded_to_test : + (unit, unit) single_scenario * string list * bool -> test_closure = + let open Lwt_syntax in + fun (s, title, is_slow) -> + let title = + match title with + | [] -> "" + | [n] -> n + | header :: tags -> + (* We chose to separate all tags with a comma, and use the head tag as a header for the test *) + header ^ ": " ^ String.concat ", " tags + in + ( title, + is_slow, + fun _proto -> + let* r = (run_scenario s) () in + match r with + | Ok () -> return_unit + | Error e -> + let m = Format.asprintf "%a@." Error_monad.pp_print_trace e in + Stdlib.failwith m ) + +let register_test ~__FILE__ ~tags ((title, is_slow, test) : test_closure) : unit + = + let tags = if is_slow then Tezos_test_helpers.Tag.slow :: tags else tags in + Tezt_tezos.Protocol.( + register_test + ~__FILE__ + ~title + ~tags + ~uses:(fun _ -> []) + ~uses_node:false + ~uses_client:false + ~uses_admin_client:false + test + [Paris]) + +let register_tests ~__FILE__ ~tags (l : test_closure list) : unit = + List.iter (register_test ~__FILE__ ~tags) l + +(** Useful aliases and operators *) + +(* Aliases for [Empty]. Can be used as first component of a scenario instead of a tag if its not needed. *) +let noop = Empty + +let no_tag = Empty + +let concat : + type a b c. (a, b) scenarios -> (b, c) scenarios -> (a, c) scenarios = + fun a b -> + match (a, b) with + | Empty, Empty -> Empty + | _, Empty -> a + | Empty, _ -> b + | _ -> Concat (a, b) + +let branch : type a b. (a, b) scenarios -> (a, b) scenarios -> (a, b) scenarios + = + fun a b -> match (a, b) with Empty, Empty -> Empty | _ -> Branch (a, b) + +(** Continuation connector: execute a then b *) +let ( --> ) a b = concat a b + +(** Branching connector: creates two tests with different execution paths *) +let ( |+ ) a b = branch a b + +(** Ends the test. Dump the state, returns [unit] *) +let end_test : ('a, unit) scenarios = + let open Lwt_result_syntax in + Action + (fun _ -> + Log.info ~color:begin_end_color "-- End test --" ; + return_unit) + +(** Transforms scenarios into tests *) +let tests_of_scenarios : + (string * (unit, 't) scenarios) list -> test_closure list = + fun scenarios -> + List.map (fun (s, x) -> Tag s --> x --> end_test) scenarios |> function + | [] -> [] + | a :: t -> + List.fold_left ( |+ ) a t |> unfold_scenarios |> List.map unfolded_to_test + +(** Arbitrary execution *) +let exec f = Action f + +(** Execute a function that does not modify the block, only the state *) +let exec_state f = + let open Lwt_result_syntax in + Action + (fun ((block, _state) as input) -> + let* state = f input in + return (block, state)) + +(** Execute a function that does not modify neither the block nor the state. + Usually used for checks/asserts *) +let exec_unit f = + let open Lwt_result_syntax in + Action + (fun input -> + let* () = f input in + return input) + +(** [fold f l] folds [f] over [l], fails on empty list *) +let rec fold : ('a -> ('b, 'c) scenarios) -> 'a list -> ('b, 'c) scenarios = + fun f list -> + match list with + | [] -> Stdlib.failwith "Scenario_dsl.fold: empty list" + | [x] -> f x + | h :: t -> f h |+ fold f t + +(** [fold_tag f l] folds [f] over [l], [l] has a tag for each of its elements. + Fails on empty list. *) +let fold_tag : + ('a -> ('b, 'c) scenarios) -> (string * 'a) list -> ('b, 'c) scenarios = + fun f -> + let f (s, x) = Tag s --> f x in + fold f + +(** [fold_tag_f f tag l] folds [f] over [l], [tag] returns a tag for each element of [l]. + Fails on empty list. *) +let fold_tag_f : + ('a -> ('b, 'c) scenarios) -> + ('a -> string) -> + 'a list -> + ('b, 'c) scenarios = + fun f tag -> + let f x = Tag (tag x) --> f x in + fold f + +(** [unfold f l] maps [f] over [l], and runs them in order *) +let rec unfold : ('a -> ('b, 'b) scenarios) -> 'a list -> ('b, 'b) scenarios = + fun f -> function [] -> Empty | [x] -> f x | h :: t -> f h --> unfold f t diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_op.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_op.ml new file mode 100644 index 0000000000000000000000000000000000000000..d12946b258bcf35caa16240d6d9f6cb6879ede32 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_op.ml @@ -0,0 +1,604 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module gathers many protocol operations in the form of scenarios. + This includes (but is not limited to) transfers and such (stake, + unstake...), as well as various ways to forge double signings. *) + +open Log_helpers +open State_account +open Adaptive_issuance_helpers +open Scenario_dsl +open Scenario_base +open Scenario_bake +open Tez_helpers.Ez_tez + +let normalize_parameters + {limit_of_staking_over_baking; edge_of_baking_over_staking} state = + let actual_limit = + Q.( + mul limit_of_staking_over_baking (1_000_000 // 1) + |> to_int |> of_int + |> mul (1 // 1_000_000)) + |> Q.max Q.zero + |> Q.min + (Q.of_int + state.State.constants.adaptive_issuance + .global_limit_of_staking_over_baking) + in + let actual_edge = + Q.( + mul edge_of_baking_over_staking (1_000_000_000 // 1) + |> to_int |> of_int + |> mul (1 // 1_000_000_000)) + |> Q.max Q.zero |> Q.min Q.one + in + { + limit_of_staking_over_baking = actual_limit; + edge_of_baking_over_staking = actual_edge; + } + +(** Set delegate parameters for the given delegate *) +let set_delegate_params delegate_name parameters : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + (* Simple example of action_atom definition: *) + let delegate = State.find_account delegate_name state in + Log.info + ~color:action_color + "[Set delegate parameters for \"%s\"]" + delegate_name ; + (* Define the operation *) + let* operation = + set_delegate_parameters (B block) delegate.contract ~parameters + in + (* Update state *) + let norm_parameters = normalize_parameters parameters state in + let wait = state.constants.delegate_parameters_activation_delay in + let state = + { + state with + param_requests = + (delegate_name, norm_parameters, wait) :: state.param_requests; + } + in + (* Return both *) + return (state, [operation])) + +(** Add a new account with the given name *) +let add_account name : (t, t) scenarios = + let open Lwt_result_syntax in + exec_state (fun (_block, state) -> + Log.info ~color:action_color "[Add account \"%s\"]" name ; + let new_account = Account.new_account () in + let pkh = new_account.pkh in + let contract = Protocol.Alpha_context.Contract.Implicit pkh in + let account_state = + init_account ~pkh ~contract ~parameters:default_params () + in + let state = State.update_account name account_state state in + return state) + +(** Reveal operation *) +let reveal name : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let account = State.find_account name state in + Log.info ~color:action_color "[Reveal \"%s\"]" name ; + let* acc = Account.find account.pkh in + let* operation = + Op.revelation ~fee:Protocol.Alpha_context.Tez.zero (B block) acc.pk + in + return (state, [operation])) + +(** Transfer from src to dst *) +let transfer src_name dst_name amount : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let src = State.find_account src_name state in + let dst = State.find_account dst_name state in + let amount = quantity_to_tez src.liquid amount in + Log.info + ~color:action_color + "[Transfer \"%s\" -> \"%s\" (%aꜩ)]" + src_name + dst_name + Tez.pp + amount ; + let* operation = + Op.transaction ~fee:Tez.zero (B block) src.contract dst.contract amount + in + let state = State.apply_transfer amount src_name dst_name state in + return (state, [operation])) + +let current_cycle block = + (* operation will be baked in next block *) + let predecessor_cycle = Block.current_cycle block in + if Block.last_block_of_cycle block then Cycle.succ predecessor_cycle + else predecessor_cycle + +(** Set delegate for src. If [delegate_name_opt = None], then unset current delegate *) +let set_delegate src_name delegate_name_opt : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let src = State.find_account src_name state in + let delegate_pkh_opt = + match delegate_name_opt with + | None -> + Log.info ~color:action_color "[Unset delegate of \"%s\"]" src_name ; + None + | Some delegate_name -> + let delegate = State.find_account delegate_name state in + Log.info + ~color:action_color + "[Set delegate \"%s\" for \"%s\"]" + delegate_name + src_name ; + Some delegate.pkh + in + let is_not_changing_delegate = + Option.equal String.equal delegate_name_opt src.delegate + in + let current_cycle = current_cycle block in + let* operation = + Op.delegation ~fee:Tez.zero (B block) src.contract delegate_pkh_opt + in + let balance = balance_of_account src_name state.account_map in + let state = + if Q.(equal balance.staked_b zero) || is_not_changing_delegate then + state + else + let state = + State.apply_unstake current_cycle Tez.max_tez src_name state + in + (* Changing delegate applies finalize if unstake happened *) + State.apply_finalize src_name state + in + let state = State.update_delegate src_name delegate_name_opt state in + let pred_level = block.header.shell.level in + let level = Int32.(succ pred_level) in + let activity_cycle = + Block.current_cycle_of_level + ~blocks_per_cycle:state.constants.blocks_per_cycle + ~current_level:level + in + (* update delegate activation status *) + let state = + (* if self delegating *) + if Option.equal String.equal delegate_name_opt (Some src_name) then + let src = State.find_account src_name state in + State.update_map + ~f:(fun acc_map -> + String.Map.add + src_name + (Account_helpers.update_activity + src + state.constants + ~level + activity_cycle) + acc_map) + state + else state + in + return (state, [operation])) + +(** Stake operation *) +let stake src_name stake_value : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let src = State.find_account src_name state in + Log.info + ~color:action_color + "[Stake for \"%s\" (%a)]" + src_name + tez_quantity_pp + stake_value ; + (* Stake applies finalize *before* the stake *) + let state = State.apply_finalize src_name state in + let amount = quantity_to_tez src.liquid stake_value in + let current_cycle = current_cycle block in + let* operation = stake (B block) src.contract amount in + let state = State.apply_stake amount current_cycle src_name state in + return (state, [operation])) + +(** unstake operation *) +let unstake src_name unstake_value : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let src = State.find_account src_name state in + Log.info + ~color:action_color + "[Unstake for \"%s\" (%a)]" + src_name + tez_quantity_pp + unstake_value ; + let stake_balance = + (balance_of_account src_name state.account_map).staked_b + |> Partial_tez.to_tez ~round:`Down + in + let amount = quantity_to_tez stake_balance unstake_value in + let* operation = unstake (B block) src.contract amount in + let cycle = current_cycle block in + let balance = balance_of_account src_name state.account_map in + let state = + if Q.(equal balance.staked_b zero) then state + else + let state = State.apply_unstake cycle amount src_name state in + State.apply_finalize src_name state + in + return (state, [operation])) + +(** finalize unstake operation *) +let finalize_unstake src_name : (t, t) scenarios = + exec_op (fun (block, state) -> + let open Lwt_result_syntax in + let src = State.find_account src_name state in + Log.info ~color:action_color "[Finalize_unstake for \"%s\"]" src_name ; + let* operation = finalize_unstake (B block) src.contract in + let state = State.apply_finalize src_name state in + return (state, [operation])) + +(* ======== Slashing ======== *) + +let check_pending_slashings ~loc (block, state) : unit tzresult Lwt.t = + let open Lwt_result_syntax in + let* denunciations_rpc = Context.get_denunciations (B block) in + Slashing_helpers.Full_denunciation.check_same_lists_any_order + ~loc + denunciations_rpc + state.State.pending_slashes + +(** Double attestation helpers *) +let order_attestations ~correct_order op1 op2 = + let oph1 = Protocol.Alpha_context.Operation.hash op1 in + let oph2 = Protocol.Alpha_context.Operation.hash op2 in + let c = Operation_hash.compare oph1 oph2 in + if correct_order then if c < 0 then (op1, op2) else (op2, op1) + else if c < 0 then (op2, op1) + else (op1, op2) + +let op_double_attestation ?(correct_order = true) op1 op2 ctxt = + let e1, e2 = order_attestations ~correct_order op1 op2 in + Op.double_attestation ctxt e1 e2 + +let op_double_preattestation ?(correct_order = true) op1 op2 ctxt = + let e1, e2 = order_attestations ~correct_order op1 op2 in + Op.double_preattestation ctxt e1 e2 + +let order_block_hashes ~correct_order bh1 bh2 = + let hash1 = Protocol.Alpha_context.Block_header.hash bh1 in + let hash2 = Protocol.Alpha_context.Block_header.hash bh2 in + let c = Block_hash.compare hash1 hash2 in + if correct_order then if c < 0 then (bh1, bh2) else (bh2, bh1) + else if c < 0 then (bh2, bh1) + else (bh1, bh2) + +let op_double_baking ?(correct_order = true) bh1 bh2 ctxt = + let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in + Op.double_baking ctxt bh1 bh2 + +(** [double_bake_op delegate_names (block, state)] performs a double baking with + the given delegate names. The first delegate in the list bakes the new main + branch. All delegates (including the first) will bake two other blocks at + the same level/different round. *) +let double_bake_op delegate_names (block, state) = + let open Lwt_result_syntax in + Log.info + ~color:event_color + "Double baking with (%s)" + (String.concat ", " delegate_names) ; + let delegates = + List.map + (fun delegate_name -> State.find_account delegate_name state) + delegate_names + in + let* main_branch, state = + bake + ~baker:(WithExceptions.Option.get ~loc:__LOC__ @@ List.hd delegate_names) + (block, state) + in + let* state = + List.fold_left_es + (fun state delegate -> + let* operation = + Adaptive_issuance_helpers.unstake + (B block) + delegate.contract + Tez.one_mutez + in + let* forked_block1 = + Block.bake ~policy:(By_account delegate.pkh) block + in + let* forked_block2 = + Block.bake ~policy:(By_account delegate.pkh) ~operation block + in + (* includes pending operations *) + let evidence = + op_double_baking forked_block1.header forked_block2.header + in + let*? misbehaviour = + Slashing_helpers.Misbehaviour_repr.from_duplicate_block forked_block1 + in + let dss = + { + State.culprit = delegate.pkh; + denounced = false; + evidence; + misbehaviour; + } + in + return + { + state with + State.double_signings = dss :: state.State.double_signings; + }) + state + delegates + in + return (main_branch, state) + +(* Note: advances one block *) +let double_bake delegate_name : (t, t) scenarios = + exec (double_bake_op [delegate_name]) + +let double_bake_many delegate_names : (t, t) scenarios = + exec (double_bake_op delegate_names) + +(** [double_attest_op ?other_bakers ~op ~op_evidence ~kind delegate_names + (block, state)] performs a double (pre)attestation with the given delegate + names. Starting at block level `n`, it creates two 2-block branches and all + delegates will (pre)attest the two blocks at level `n+2`. [other_bakers] can + be used to force using specific bakers to avoid reusing forbidden ones *) +let double_attest_op ?other_bakers ~op ~op_evidence ~kind delegate_names + (block, state) = + let open Lwt_result_syntax in + Log.info + ~color:event_color + "Double %s with %a" + (match kind with + | Protocol.Misbehaviour_repr.Double_preattesting -> "preattesting" + | Double_attesting -> "attesting" + | Double_baking -> assert false) + (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) + delegate_names ; + let delegates = + List.map + (fun delegate_name -> State.find_account delegate_name state) + delegate_names + in + let* baker, _, _, _ = + Block.get_next_baker ?policy:state.baking_policy block + in + Log.info "Baker: %a" Signature.Public_key_hash.pp baker ; + let* other_baker1, other_baker2 = + match other_bakers with + | Some (ob1, ob2) -> + let ob1 = (State.find_account ob1 state).pkh in + let ob2 = (State.find_account ob2 state).pkh in + return (ob1, ob2) + | None -> Context.get_first_different_bakers (B block) + in + let other_baker = + if not (Signature.Public_key_hash.equal baker other_baker2) then + other_baker2 + else other_baker1 + in + Log.info "Other baker: %a" Signature.Public_key_hash.pp other_baker ; + Log.info "Bake 1 block with %a" Signature.Public_key_hash.pp baker ; + let* forked_block = Block.bake ~policy:(By_account other_baker) block in + Log.info "Bake 1 block " ; + let* forked_block = Block.bake ?policy:state.baking_policy forked_block in + Log.info "Baked two blocks" ; + (* includes pending operations *) + let* block, state = bake (block, state) in + let* main_branch, state = bake (block, state) in + List.fold_left_es + (fun (main_branch, state) delegate -> + let* attestation_a = op ~delegate:delegate.pkh forked_block in + let* attestation_b = op ~delegate:delegate.pkh main_branch in + let evidence = op_evidence attestation_a attestation_b in + let dss = + { + State.culprit = delegate.pkh; + denounced = false; + evidence; + misbehaviour = + Slashing_helpers.Misbehaviour_repr.from_duplicate_operation + attestation_a; + } + in + let state : State.t = + {state with double_signings = dss :: state.State.double_signings} + in + return (main_branch, state)) + (main_branch, state) + delegates + +let double_attest_ = + double_attest_op + ~op:(fun ~delegate block -> Op.raw_attestation ~delegate block) + ~op_evidence:op_double_attestation + ~kind:Double_attesting + +(* Note: advances two blocks *) +let double_attest_many ?other_bakers delegate_names : (t, t) scenarios = + exec (double_attest_ ?other_bakers delegate_names) + +let double_attest ?other_bakers delegate_name : (t, t) scenarios = + double_attest_many ?other_bakers [delegate_name] + +let double_preattest_ = + double_attest_op + ~op:(fun ~delegate block -> Op.raw_preattestation ~delegate block) + ~op_evidence:op_double_preattestation + ~kind:Double_preattesting + +(* Note: advances two blocks *) +let double_preattest_many ?other_bakers delegate_names : (t, t) scenarios = + exec (double_preattest_ ?other_bakers delegate_names) + +let double_preattest ?other_bakers delegate_name : (t, t) scenarios = + double_preattest_many ?other_bakers [delegate_name] + +let cycle_from_level blocks_per_cycle level = + let current_cycle = Int32.div level blocks_per_cycle in + let current_cycle = Cycle.add Cycle.root (Int32.to_int current_cycle) in + current_cycle + +let pct_from_kind (block : Block.t) = function + | Protocol.Misbehaviour_repr.Double_baking -> + Protocol.Percentage.to_q + block.constants.percentage_of_frozen_deposits_slashed_per_double_baking + |> Q.(mul (100 // 1)) + |> Q.to_int + | Double_attesting | Double_preattesting -> + Protocol.Percentage.to_q + block.constants + .percentage_of_frozen_deposits_slashed_per_double_attestation + |> Q.(mul (100 // 1)) + |> Q.to_int + +let get_pending_slashed_pct_for_delegate (block, state) delegate = + let rec aux r = function + | [] -> r + | (culprit, {Protocol.Denunciations_repr.misbehaviour; _}) :: t -> + if Signature.Public_key_hash.equal delegate culprit then + let new_r = r + pct_from_kind block misbehaviour.kind in + if new_r >= 100 then 100 else aux new_r t + else aux r t + in + aux 0 state.State.pending_slashes + +let update_state_denunciation (block, state) + {State.culprit; denounced; evidence = _; misbehaviour} = + let open Lwt_result_syntax in + if denounced then ( + (* If the double signing has already been denounced, a second denunciation should fail *) + Log.info ~color:event_color "Denunciation already included" ; + return (state, denounced)) + else + let*? block_level = Context.get_level (B block) in + let next_level = + Protocol.Alpha_context.Raw_level.(to_int32 @@ succ block_level) + in + let inclusion_cycle = + cycle_from_level block.constants.blocks_per_cycle next_level + in + let ds_level = Protocol.Raw_level_repr.to_int32 misbehaviour.level in + let ds_cycle = cycle_from_level block.constants.blocks_per_cycle ds_level in + if Cycle.(ds_cycle > inclusion_cycle) then ( + (* The denunciation is trying to be included too early *) + Log.info ~color:event_color "Denunciation too early" ; + return (state, denounced)) + else if + Cycle.( + add ds_cycle Protocol.Constants_repr.max_slashing_period + <= inclusion_cycle) + then ( + (* The denunciation is too late and gets refused. *) + Log.info ~color:event_color "Denunciation too late" ; + return (state, denounced)) + else + (* for simplicity's sake (lol), the block producer and the payload producer are the same + We also assume that the current state baking policy will be used for the next block *) + let* rewarded, _, _, _ = + Block.get_next_baker ?policy:state.State.baking_policy block + in + let culprit_name, culprit_account = + State.find_account_from_pkh culprit state + in + let state = + State.update_account + culprit_name + { + culprit_account with + slashed_cycles = inclusion_cycle :: culprit_account.slashed_cycles; + } + state + in + let new_pending_slash = + ( culprit, + { + Protocol.Denunciations_repr.rewarded; + misbehaviour; + operation_hash = Operation_hash.zero; + (* unused *) + } ) + in + (* TODO: better log... *) + Log.info + ~color:event_color + "Including denunciation (misbehaviour cycle %a)" + Cycle.pp + ds_cycle ; + let state = + State. + { + state with + pending_slashes = new_pending_slash :: state.pending_slashes; + } + in + return (state, true) + +(** [make_denunciations_op ?single ?rev ?filter ()] denounces all double signers + in the state. If [single] is set, only one denunciation is made. If [rev] is + set, the denunciations are made in reverse order. If [filter] is set, only the + double signers for which the filter returns true are denounced. *) +let make_denunciations_op ?(single = false) ?(rev = false) + ?(filter = fun {State.denounced; _} -> not denounced) (block, state) = + let open Lwt_result_syntax in + let* () = check_pending_slashings ~loc:__LOC__ (block, state) in + let make_op state ({State.evidence; _} as dss) = + if filter dss then + let* state, denounced = update_state_denunciation (block, state) dss in + return (Some (evidence (B block), {dss with denounced}, state)) + else return None + in + let rec make_op_list dss_list state r_op r_dss = + match dss_list with + | d :: t -> ( + let open State in + let* new_op = make_op state d in + match new_op with + | None -> make_op_list t state r_op (d :: r_dss) + | Some (op, p_dss, new_state) -> + Log.info + ~color:event_color + "Denouncing %a for %s at level %a round %a" + Signature.Public_key_hash.pp + d.culprit + (match d.misbehaviour.kind with + | Double_baking -> "double baking" + | Double_attesting -> "double attesting" + | Double_preattesting -> "double preattesting") + Protocol.Raw_level_repr.pp + d.misbehaviour.level + Protocol.Round_repr.pp + d.misbehaviour.round ; + if single then + return @@ (new_state, op :: r_op, List.rev @@ (p_dss :: t)) + else make_op_list t new_state (op :: r_op) (p_dss :: r_dss)) + | [] -> return @@ (state, r_op, r_dss) + in + let* state, operations, double_signings = + make_op_list + (if rev then state.double_signings else List.rev state.double_signings) + state + [] + [] + in + let state = {state with double_signings} in + return (state, operations) + +(* Important note: do not change the baking policy behaviour once denunciations are made, + until the operations are included in a block (by default the next block) *) +let make_denunciations ?single ?rev ?filter () = + exec_op (make_denunciations_op ?single ?rev ?filter) + +(** Create an account and give an initial balance funded by [funder] *) +let add_account_with_funds name ~funder amount = + add_account name --> transfer funder name amount --> reveal name diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..4de8fb8d37764849d677bde5d1db6ba9816fed4a --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.ml @@ -0,0 +1,275 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +module Misbehaviour_repr = struct + open Protocol.Misbehaviour_repr + + let pp fmt {level; round; kind} = + Format.fprintf + fmt + "misbehaviour: %s at level %a round %a" + (match kind with + | Double_baking -> "double baking" + | Double_attesting -> "double attesting" + | Double_preattesting -> "double preattesting") + Protocol.Raw_level_repr.pp + level + Protocol.Round_repr.pp + round + + include Compare.Make (struct + type t = Protocol.Misbehaviour_repr.t + + let compare = Protocol.Misbehaviour_repr.compare + end) + + let from_duplicate_operation (type a) + (duplicate_op : + a Protocol.Alpha_context.Kind.consensus Protocol.Alpha_context.operation) + = + let ( ({slot = _; level; round; block_payload_hash = _} : + Protocol.Alpha_context.consensus_content), + kind ) = + match duplicate_op.protocol_data.contents with + | Single (Preattestation consensus_content) -> + (consensus_content, Double_preattesting) + | Single (Attestation {consensus_content; _}) -> + (consensus_content, Double_attesting) + in + let level = + Protocol.Alpha_context.Raw_level.Internal_for_tests.to_repr level + in + let round = Protocol.Alpha_context.Round.Internal_for_tests.to_repr round in + {level; round; kind} + + let check_from_duplicate_operation ~loc misbehaviour duplicate_op = + Assert.equal + ~loc + equal + "misbehaviours are not equal" + pp + misbehaviour + (from_duplicate_operation duplicate_op) + + let from_duplicate_block (b : Block.t) = + let open Result_wrap_syntax in + let open Result_syntax in + let*@ level = Protocol.Raw_level_repr.of_int32 b.header.shell.level in + let*@ round = Protocol.Fitness_repr.round_from_raw b.header.shell.fitness in + return {kind = Double_baking; level; round} +end + +module Denunciations_repr = struct + open Protocol.Denunciations_repr + + let pp_item fmt {operation_hash = _; rewarded; misbehaviour} = + Format.fprintf + fmt + "rewarded: %a; %a" + Signature.Public_key_hash.pp + rewarded + Misbehaviour_repr.pp + misbehaviour + + let compare_item_except_hash + {operation_hash = _; rewarded = r1; misbehaviour = m1} + {operation_hash = _; rewarded = r2; misbehaviour = m2} = + Compare.or_else (Protocol.Misbehaviour_repr.compare m1 m2) @@ fun () -> + Signature.Public_key_hash.compare r1 r2 +end + +module Full_denunciation = struct + open Protocol.Denunciations_repr + + type t = Signature.Public_key_hash.t * item + + let pp fmt (culprit, item) = + Format.fprintf + fmt + "culprit: %a; %a" + Signature.Public_key_hash.pp + culprit + Denunciations_repr.pp_item + item + + let compare_except_hash (culprit1, item1) (culprit2, item2) = + Compare.or_else (Signature.Public_key_hash.compare culprit1 culprit2) + @@ fun () -> Denunciations_repr.compare_item_except_hash item1 item2 + + let check_same_lists_any_order ~loc list1 list2 = + Assert.equal_list_any_order + ~loc + ~compare:compare_except_hash + "denunciation lists are not the same (not taking order into account)" + pp + list1 + list2 +end + +let apply_slashing_account all_denunciations_to_apply + ( culprit, + Protocol.Denunciations_repr.{rewarded; misbehaviour; operation_hash = _} + ) (block_before_slash : Block.t) (state : State.t) = + let open Lwt_result_syntax in + let open State_account in + let constants = state.constants in + let (account_map : State_account.account_map) = state.account_map in + let find_account_name_from_pkh_exn pkh account_map = + match + Option.map + fst + String.Map.( + choose + @@ filter + (fun _ account -> + Signature.Public_key_hash.equal pkh account.State_account.pkh) + account_map) + with + | None -> assert false + | Some x -> x + in + let slashed_cycle = + Block.current_cycle_of_level + ~blocks_per_cycle: + constants.Protocol.Alpha_context.Constants.Parametric.blocks_per_cycle + ~current_level:(Protocol.Raw_level_repr.to_int32 misbehaviour.level) + in + let culprit_name = find_account_name_from_pkh_exn culprit account_map in + let rewarded_name = find_account_name_from_pkh_exn rewarded account_map in + Log.info + "Slashing %a for %a" + Signature.Public_key_hash.pp + culprit + Misbehaviour_repr.pp + misbehaviour ; + let* slashed_pct = + match misbehaviour.kind with + | Double_baking -> + return + constants + .Protocol.Alpha_context.Constants.Parametric + .percentage_of_frozen_deposits_slashed_per_double_baking + | Double_attesting | Double_preattesting -> + State_ai_flags.NS.get_double_attestation_slashing_percentage + all_denunciations_to_apply + block_before_slash + state + misbehaviour + in + let slash_culprit + ({frozen_deposits; unstaked_frozen; frozen_rights; parameters; _} as acc) + = + Log.info + "Slashing %a for %a with frozen deposits: { %a }" + Signature.Public_key_hash.pp + acc.pkh + Misbehaviour_repr.pp + misbehaviour + Frozen_tez.pp + frozen_deposits ; + let base_rights = + CycleMap.find slashed_cycle frozen_rights + |> Option.value ~default:Tez.zero + in + Log.info "Base rights: %a" Tez.pp base_rights ; + let frozen_deposits, burnt_frozen, rewarded_frozen = + Frozen_tez.slash + ~limit:parameters.limit_of_staking_over_baking + state.constants + base_rights + slashed_pct + frozen_deposits + in + let slashed_pct_q = Protocol.Percentage.to_q slashed_pct in + let slashed_pct = Q.(100 // 1 * slashed_pct_q |> to_int) in + Log.info "Slashed %d%% of frozen deposits@." slashed_pct ; + let unstaked_frozen, slashed_unstaked = + Unstaked_frozen.slash + state.constants + ~slashable_deposits_period:constants.consensus_rights_delay + slashed_cycle + slashed_pct + unstaked_frozen + in + ( {acc with frozen_deposits; unstaked_frozen}, + (burnt_frozen, rewarded_frozen) :: slashed_unstaked ) + in + let culprit_account = + String.Map.find culprit_name account_map + |> Option.value_f ~default:(fun () -> + fail_account_not_found "apply_slashing" culprit_name) + in + let slashed_culprit_account, total_slashed = slash_culprit culprit_account in + Log.info "Slashed %a@." Signature.Public_key_hash.pp culprit_account.pkh ; + let account_map = + update_account + ~f:(fun _ -> slashed_culprit_account) + culprit_name + account_map + in + (* For each container slashed, the snitch gets a reward transferred. It gets rounded + down each time *) + let reward_to_snitch = + List.map snd total_slashed |> List.fold_left Tez.( +! ) Tez.zero + in + let account_map = + add_liquid_rewards reward_to_snitch rewarded_name account_map + in + let total_burnt_amount = + List.map fst total_slashed |> List.fold_left Tez.( +! ) Tez.zero + in + Log.info "Total burnt amount: %a" Tez.pp total_burnt_amount ; + return (account_map, total_burnt_amount) + +let apply_slashing_state all_denunciations_to_apply + ( culprit, + Protocol.Denunciations_repr.{rewarded; misbehaviour; operation_hash} ) + block_before_slash (state : State.t) : + (State.t * Tez_helpers.t) tzresult Lwt.t = + let open Lwt_result_syntax in + let* account_map, total_burnt = + apply_slashing_account + all_denunciations_to_apply + (culprit, {rewarded; misbehaviour; operation_hash}) + block_before_slash + state + in + (* TODO: add culprit's stakers *) + let log_updates = + List.map + (fun x -> fst @@ State.find_account_from_pkh x state) + [culprit; rewarded] + in + let state = State.update_map ~log_updates ~f:(fun _ -> account_map) state in + return (state, total_burnt) + +let apply_all_slashes_at_cycle_end current_cycle (block_before_slash : Block.t) + (state : State.t) : State.t tzresult Lwt.t = + let open Lwt_result_syntax in + let to_slash_later, to_slash_now = + State_ai_flags.Delayed_slashing.partition_slashes state current_cycle + in + (* Sort to_slash_now by level+round *) + let to_slash_now = + List.sort + (fun (_, item1) (_, item2) -> + Denunciations_repr.compare_item_except_hash item1 item2) + to_slash_now + in + + let* state, total_burnt = + List.fold_left_es + (fun (acc_state, acc_total) x -> + let* state, burnt = + apply_slashing_state to_slash_now x block_before_slash acc_state + in + return (state, Tez_helpers.(acc_total +! burnt))) + (state, Tez_helpers.zero) + to_slash_now + in + let total_supply = Tez_helpers.(state.total_supply -! total_burnt) in + return {state with pending_slashes = to_slash_later; total_supply} diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.mli b/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.mli new file mode 100644 index 0000000000000000000000000000000000000000..106d5c250cd450919c411fc7dbb4cc7a3cc6e066 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +(** Helpers related to denunciations and slashing. *) + +(** Helpers related to {!Protocol.Misbehaviour_repr}. *) +module Misbehaviour_repr : sig + val pp : Format.formatter -> Protocol.Misbehaviour_repr.t -> unit + + (** Builds a misbehaviour object from either of the duplicate + (pre)attestations that constitute a double (pre)attestating + event. *) + val from_duplicate_operation : + 'kind Protocol.Alpha_context.Kind.consensus Protocol.Alpha_context.operation -> + Protocol.Misbehaviour_repr.t + + (** [check_from_duplicate_operation ~loc misbehaviour duplicate_op] + asserts that [misbehaviour] correctly describes a double signing + event involving [duplicate_op]. *) + val check_from_duplicate_operation : + loc:string -> + Tezos_raw_protocol_019_PtParisB.Misbehaviour_repr.t -> + 'kind Protocol.Alpha_context.Kind.consensus Protocol.Alpha_context.operation -> + unit tzresult Lwt.t + + (** Builds a misbehaviour object from either of the duplicate blocks + that constitute a double baking event. *) + val from_duplicate_block : Block.t -> Protocol.Misbehaviour_repr.t tzresult +end + +(** Helpers about "full denunciations", that is, a denunciation item + and its culprit. See type [t] of this module. *) +module Full_denunciation : sig + (** A denunciation item preceded by the culprit's pkh. Indeed, the + culprit isn't recorded inside the + {!Protocol.Denunciations_repr.item} because it serves as a key + in the protocol's storage instead. But we often need both + together in the tests. *) + type t = Signature.Public_key_hash.t * Protocol.Denunciations_repr.item + + (** Asserts that both lists contain the same elements. + + These elements may be ordered differently, but must have the + same multiplicity in both lists. *) + val check_same_lists_any_order : + loc:string -> t list -> t list -> unit tzresult Lwt.t +end + +(** Applies all slashes at cycle end in the state *) +val apply_all_slashes_at_cycle_end : + Protocol.Alpha_context.Cycle.t -> Block.t -> State.t -> State.t tzresult Lwt.t diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/state.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/state.ml new file mode 100644 index 0000000000000000000000000000000000000000..6e245b1d77cad696202f76d06b84ac95b46571de --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/state.ml @@ -0,0 +1,202 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open Adaptive_issuance_helpers +open State_account +open Log_helpers + +type double_signing_state = { + culprit : Signature.Public_key_hash.t; + evidence : Context.t -> Protocol.Alpha_context.packed_operation; + denounced : bool; + misbehaviour : Protocol.Misbehaviour_repr.t; +} + +(** Type of the state *) +type t = { + account_map : account_map; + total_supply : Tez.t; + constants : Protocol.Alpha_context.Constants.Parametric.t; + param_requests : (string * staking_parameters * int) list; + force_ai_vote_yes : bool; + baking_policy : Block.baker_policy option; + last_level_rewards : Protocol.Alpha_context.Raw_level.t; + snapshot_balances : (string * balance) list String.Map.t; + saved_rate : Q.t option; + burn_rewards : bool; + pending_operations : Protocol.Alpha_context.packed_operation list; + pending_slashes : + (Signature.Public_key_hash.t * Protocol.Denunciations_repr.item) list; + double_signings : double_signing_state list; + ai_activation_cycle : Protocol.Alpha_context.Cycle.t option; + force_attest_all : bool; +} + +(** Expected number of cycles before staking parameters get applied *) +let param_wait state = state.constants.delegate_parameters_activation_delay + 1 + +(** Expected number of cycles before staking unstaked funds get unfrozen *) +let unstake_wait state = + let pc = state.constants.consensus_rights_delay in + let msp = Protocol.Constants_repr.max_slashing_period in + pc + msp + +(** From a name, returns the corresponding account *) +let find_account (account_name : string) (state : t) : account_state = + match String.Map.find account_name state.account_map with + | None -> + Log.error "State.find_account: account %s not found" account_name ; + assert false + | Some r -> r + +let find_account_from_pkh (pkh : Signature.public_key_hash) (state : t) : + string * account_state = + String.Map.filter + (fun _ acc -> Signature.Public_key_hash.equal pkh acc.pkh) + state.account_map + |> String.Map.choose + |> function + | None -> + Log.error + "State.find_account_from_pkh: account %a not found" + Signature.Public_key_hash.pp + pkh ; + assert false + | Some (name, acc) -> (name, acc) + +let liquid_delegated ~name state = + let open Result_syntax in + String.Map.fold_e + (fun _delegator account acc -> + match account.delegate with + | Some delegate when not @@ String.equal delegate name -> return acc + | None -> return acc + | _ -> Tez.(acc +? account.liquid)) + state.account_map + Tez.zero + +(** Returns true iff account is a delegate *) +let is_self_delegate (account_name : string) (state : t) : bool = + let acc = find_account account_name state in + match acc.delegate with + | None -> false + | Some del_name -> String.equal del_name account_name + +let update_map ?(log_updates = []) ~(f : account_map -> account_map) (state : t) + : t = + let log_updates = List.sort_uniq String.compare log_updates in + let new_state = {state with account_map = f state.account_map} in + List.iter + (fun x -> + log_debug_balance_update x state.account_map new_state.account_map) + log_updates ; + new_state + +let update_map_es ?(log_updates = []) + ~(f : account_map -> account_map tzresult Lwt.t) (state : t) : + t tzresult Lwt.t = + let open Lwt_result_syntax in + let log_updates = List.sort_uniq String.compare log_updates in + let* account_map = f state.account_map in + let new_state = {state with account_map} in + List.iter + (fun x -> + log_debug_balance_update x state.account_map new_state.account_map) + log_updates ; + return new_state + +let apply_burn amount src_name (state : t) : t = + let f = apply_burn amount src_name in + let state = update_map ~log_updates:[src_name] ~f state in + {state with total_supply = Tez.(state.total_supply -! amount)} + +let apply_transfer amount src_name dst_name (state : t) : t = + let f = apply_transfer amount src_name dst_name in + update_map ~log_updates:[src_name; dst_name] ~f state + +let apply_stake amount current_cycle staker_name (state : t) : t = + let f = + apply_stake + amount + current_cycle + state.constants.consensus_rights_delay + staker_name + in + update_map ~log_updates:[staker_name] ~f state + +let apply_unstake cycle amount staker_name (state : t) : t = + let f = apply_unstake cycle amount staker_name in + update_map ~log_updates:[staker_name] ~f state + +let apply_finalize staker_name (state : t) : t = + let f = apply_finalize staker_name in + update_map ~log_updates:[staker_name] ~f state + +let apply_unslashable current_cycle account_name (state : t) : t = + let unstake_wait = unstake_wait state in + match Cycle.sub current_cycle unstake_wait with + | None -> state + | Some cycle -> + let f = apply_unslashable cycle account_name in + update_map ~log_updates:[account_name] ~f state + +let apply_unslashable_for_all current_cycle (state : t) : t = + let unstake_wait = unstake_wait state in + match Cycle.sub current_cycle unstake_wait with + | None -> state + | Some cycle -> + let f = apply_unslashable_for_all cycle in + (* no log *) + update_map ~f state + +let apply_rewards ~(baker : string) block (state : t) : t tzresult Lwt.t = + let open Lwt_result_syntax in + let {last_level_rewards; total_supply; constants = _; _} = state in + let*? current_level = Context.get_level (B block) in + let current_cycle = Block.current_cycle block in + (* We assume one block per minute *) + let* rewards_per_block = Context.get_issuance_per_minute (B block) in + if Tez.(rewards_per_block = zero) then return state + else + let delta_time = + Protocol.Alpha_context.Raw_level.diff current_level last_level_rewards + |> Int64.of_int32 + in + let {parameters = _; pkh; _} = find_account baker state in + let delta_rewards = Tez_helpers.(rewards_per_block *! delta_time) in + if delta_time = 1L then + Log.info ~color:tez_color "+%aꜩ" Tez.pp rewards_per_block + else assert false ; + let* to_liquid = + portion_of_rewards_to_liquid_for_cycle + (B block) + current_cycle + pkh + delta_rewards + in + let to_frozen = Tez.(delta_rewards -! to_liquid) in + let state = update_map ~f:(add_liquid_rewards to_liquid baker) state in + let state = update_map ~f:(add_frozen_rewards to_frozen baker) state in + let*? total_supply = Tez.(total_supply +? delta_rewards) in + return {state with last_level_rewards = current_level; total_supply} + +(** Given an account name and new account state, updates [state] accordingly + Preferably use other specific update functions *) +let update_account (account_name : string) (value : account_state) (state : t) : + t = + let account_map = String.Map.add account_name value state.account_map in + {state with account_map} + +let update_delegate account_name delegate_name_opt state : t = + let account = find_account account_name state in + update_account account_name {account with delegate = delegate_name_opt} state + +let add_pending_operations operations state = + {state with pending_operations = state.pending_operations @ operations} + +let pop_pending_operations state = + ({state with pending_operations = []}, state.pending_operations) diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/state_account.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_account.ml new file mode 100644 index 0000000000000000000000000000000000000000..16bf5d2dba7c2bbcb2c42ce8c542d7c5c70e0826 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_account.ml @@ -0,0 +1,427 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** [State_account] is dedicated to operations in [State.t] that would modify + an [account_state]. This includes any operation like [transfer], [stake], + [unstake], [set_delegate_parameters], anything related to slashing or + rewards, etc... *) + +open Adaptive_issuance_helpers +include Tez_staking_helpers +include Account_helpers + +let add_liquid_rewards amount account_name account_map = + let f account = + let liquid = Tez.(account.liquid +! amount) in + {account with liquid} + in + update_account ~f account_name account_map + +let add_frozen_rewards amount account_name account_map = + let f account = + let frozen_deposits = + Frozen_tez.add_tez_to_all_current + ~edge:account.parameters.edge_of_baking_over_staking + ~limit:account.parameters.limit_of_staking_over_baking + amount + account.frozen_deposits + in + {account with frozen_deposits} + in + update_account ~f account_name account_map + +let apply_burn amount src_name account_map = + let f src = {src with liquid = Tez.(src.liquid -! amount)} in + update_account ~f src_name account_map + +let apply_transfer amount src_name dst_name account_map = + match + (String.Map.find src_name account_map, String.Map.find dst_name account_map) + with + | Some src, Some _ -> + if Tez.(src.liquid < amount) then + (* Invalid amount: operation will fail *) + account_map + else + let f_src src = + let liquid = Tez.(src.liquid -! amount) in + {src with liquid} + in + let f_dst dst = + let liquid = Tez.(dst.liquid +! amount) in + {dst with liquid} + in + let account_map = update_account ~f:f_src src_name account_map in + update_account ~f:f_dst dst_name account_map + | None, _ -> fail_account_not_found "apply_transfer.src" src_name + | _, None -> fail_account_not_found "apply_transfer.dst" dst_name + +let stake_from_unstake amount current_cycle consensus_rights_delay delegate_name + account_map = + match String.Map.find delegate_name account_map with + | None -> fail_account_not_found "stake_from_unstake" delegate_name + | Some ({unstaked_frozen; frozen_deposits; slashed_cycles; _} as account) -> + let oldest_slashable_cycle = + Cycle.(sub current_cycle (consensus_rights_delay + 1)) + |> Option.value ~default:Cycle.root + in + if + List.exists + (fun x -> Cycle.(x >= oldest_slashable_cycle)) + slashed_cycles + then (account_map, amount) + else + let unstaked_frozen = + List.sort + (fun (Unstaked_frozen.{cycle = cycle1; _} : Unstaked_frozen.r) + {cycle = cycle2; _} -> Cycle.compare cycle2 cycle1) + unstaked_frozen + in + let rec aux acc_unstakes rem_amount rem_unstakes = + match rem_unstakes with + | [] -> (acc_unstakes, rem_amount) + | (Unstaked_frozen.{requests; slash_pct; _} as h) :: t -> + (* Stake from unstake cannot be called when slashing happened *) + assert (Compare.Int.(slash_pct = 0)) ; + (* This ensures initial = current for each requester. + However, the "initial" field is for the sum of all unstakes, + so cannot be used here *) + let initial = + String.Map.find_opt delegate_name requests + |> Option.value ~default:Tez.zero + in + if Tez.(rem_amount = zero) then + (acc_unstakes @ rem_unstakes, Tez.zero) + else if Tez.(rem_amount >= initial) then + let h = Unstaked_frozen.sub_unstake initial delegate_name h in + let rem_amount = Tez.(rem_amount -! initial) in + aux (acc_unstakes @ [h]) rem_amount t + else + let h = + Unstaked_frozen.sub_unstake rem_amount delegate_name h + in + (acc_unstakes @ [h] @ t, Tez.zero) + in + let unstaked_frozen, rem_amount = aux [] amount unstaked_frozen in + let frozen_deposits = + Frozen_tez.add_current + Tez.(amount -! rem_amount) + delegate_name + frozen_deposits + in + let account = {account with unstaked_frozen; frozen_deposits} in + let account_map = + update_account ~f:(fun _ -> account) delegate_name account_map + in + (account_map, rem_amount) + +let apply_stake amount current_cycle consensus_rights_delay staker_name + account_map = + match String.Map.find staker_name account_map with + | None -> fail_account_not_found "apply_stake" staker_name + | Some staker -> ( + match staker.delegate with + | None -> + (* Invalid operation: no delegate *) + account_map + | Some delegate_name -> + let old_account_map = account_map in + (* If self stake, then try to stake from unstake. + Returns the amount that remains to be staked from liquid *) + let account_map, amount = + if delegate_name = staker_name then + stake_from_unstake + amount + current_cycle + consensus_rights_delay + staker_name + account_map + else (account_map, amount) + in + if Tez.(staker.liquid < amount) then + (* Not enough liquid balance: operation will fail *) + old_account_map + else if delegate_name = staker_name then + (* If self stake: increase frozen deposits and decrease liquid balance. + "add_current" is easy to resolve since there is no pseudotokens *) + let f delegate = + let frozen_deposits = + Frozen_tez.add_current + amount + staker_name + delegate.frozen_deposits + in + let liquid = Tez.(delegate.liquid -! amount) in + {delegate with frozen_deposits; liquid} + in + update_account ~f delegate_name account_map + else + (* If external stake: *) + let delegate_account = + String.Map.find delegate_name account_map + |> Option.value_f ~default:(fun _ -> assert false) + in + (* Call stake_values_real to know the actual amount staked and the pseudotokens minted *) + (* amount_q would be the effective stake on the delegate's side, while + amount is the amount removed from the liquid balance *) + let pseudo, amount_q = + stake_values_real + amount + delegate_account.staking_delegate_denominator + delegate_account.frozen_deposits + in + let f_staker staker = + let liquid = Tez.(staker.liquid -! amount) in + let staking_delegator_numerator = + Z.add staker.staking_delegator_numerator pseudo + in + {staker with liquid; staking_delegator_numerator} + in + let f_delegate delegate = + (* The difference between the actual amount and the effective amount is + "distributed" amongst current stake holders. + Indeed, when trading in "amount", the staker receives "pseudo" pseudotokens + valued at "amount_q". So the total amount of value is increased by "amount_q". + Then, "portion" is added to the total, so it must be distributed. + This means that the order is important: first you add_current_q, then + you add the portion to all *) + let portion = Partial_tez.(of_tez amount - amount_q) in + let frozen_deposits = + Frozen_tez.add_current_q + amount_q + staker_name + delegate.frozen_deposits + in + let co_current = + Frozen_tez.add_q_to_all_co_current + portion + frozen_deposits.co_current + in + let frozen_deposits = {frozen_deposits with co_current} in + let staking_delegate_denominator = + Z.add delegate.staking_delegate_denominator pseudo + in + {delegate with frozen_deposits; staking_delegate_denominator} + in + let account_map = + update_account ~f:f_staker staker_name account_map + in + update_account ~f:f_delegate delegate_name account_map) + +let apply_unstake cycle amount staker_name account_map = + match String.Map.find staker_name account_map with + | None -> fail_account_not_found "apply_unstake.staker" staker_name + | Some staker -> ( + match staker.delegate with + | None -> (* Invalid operation: no delegate *) account_map + | Some delegate_name -> ( + match String.Map.find delegate_name account_map with + | None -> + fail_account_not_found "apply_unstake.delegate" delegate_name + | Some delegate -> + if delegate_name = staker_name then + (* Case self stake *) + (* No pseudotokens : no problem *) + let frozen_deposits, amount_unstaked = + Frozen_tez.sub_current + amount + staker_name + delegate.frozen_deposits + in + let unstaked_frozen = + Unstaked_frozen.add_unstake + cycle + amount_unstaked + staker_name + delegate.unstaked_frozen + in + let delegate = + {delegate with frozen_deposits; unstaked_frozen} + in + update_account ~f:(fun _ -> delegate) delegate_name account_map + else + (* Case external stake *) + let staked_amount = + Frozen_tez.get staker_name delegate.frozen_deposits + in + let pseudotokens, amount_q = + if Partial_tez.(staked_amount <= of_tez amount) then + (* Unstake all case *) + (staker.staking_delegator_numerator, staked_amount) + else + (* The staker requests "amount". + It translates to some "pseudotokens", valued at "amount_q". + If those pseudotokens would give strictly more than the requested amount, + then give one less pseudotoken. The actual amount unstaked is always lower than + the requested amount (except in the unstake all case) *) + unstake_values_real + amount + delegate.staking_delegate_denominator + delegate.frozen_deposits + in + (* Actual unstaked amount (that will be finalized) *) + let amount = Partial_tez.to_tez ~round:`Down amount_q in + (* Delta from pseudotokens' value, to be redistributed amongst all remaining stakers + (including current if still staking) *) + let portion = Partial_tez.(amount_q - of_tez amount) in + let f_staker staker = + (* The staker's account representation doesn't change much, + the unstake request is stored on the delegate's side *) + let staking_delegator_numerator = + Z.sub staker.staking_delegator_numerator pseudotokens + in + {staker with staking_delegator_numerator} + in + let account_map = + update_account ~f:f_staker staker_name account_map + in + let f_delegate delegate = + let staking_delegate_denominator = + Z.sub delegate.staking_delegate_denominator pseudotokens + in + (* Just like in stake *) + (* Do the effective unstake *) + let frozen_deposits = + Frozen_tez.sub_current_q + amount_q + staker_name + delegate.frozen_deposits + in + (* Apply the delta *) + let co_current = + Frozen_tez.add_q_to_all_co_current + portion + frozen_deposits.co_current + in + let frozen_deposits = {frozen_deposits with co_current} in + (* Add unstake request + Note that "amount" might not be the initial requested amount *) + let unstaked_frozen = + Unstaked_frozen.add_unstake + cycle + amount + staker_name + delegate.unstaked_frozen + in + { + delegate with + staking_delegate_denominator; + frozen_deposits; + unstaked_frozen; + } + in + update_account ~f:f_delegate delegate_name account_map)) + +let apply_unslashable_f cycle delegate = + let amount_unslashable, unstaked_frozen = + Unstaked_frozen.pop_cycle cycle delegate.unstaked_frozen + in + let unstaked_finalizable = + Unstaked_finalizable.add_from_poped_ufd + amount_unslashable + delegate.unstaked_finalizable + in + {delegate with unstaked_frozen; unstaked_finalizable} + +(* Updates unstaked unslashable values for given account *) +let apply_unslashable cycle account_name account_map = + update_account ~f:(apply_unslashable_f cycle) account_name account_map + +(* Updates unstaked unslashable values in all accounts *) +let apply_unslashable_for_all cycle account_map = + String.Map.map (apply_unslashable_f cycle) account_map + +let apply_finalize staker_name account_map = + match String.Map.find staker_name account_map with + | None -> fail_account_not_found "apply_finalize" staker_name + | Some _staker -> + (* Because an account can still have finalizable funds from a delegate + that is not its own, we iterate over all of them *) + String.Map.fold + (fun delegate_name delegate account_map_acc -> + match + String.Map.find staker_name delegate.unstaked_finalizable.map + with + | None -> account_map_acc + | Some amount -> + let f_staker staker = + let liquid = Tez.(staker.liquid +! amount) in + {staker with liquid} + in + let f_delegate delegate = + let map = + String.Map.remove + staker_name + delegate.unstaked_finalizable.map + in + { + delegate with + unstaked_finalizable = + {delegate.unstaked_finalizable with map}; + } + in + let account_map_acc = + update_account ~f:f_staker staker_name account_map_acc + in + update_account ~f:f_delegate delegate_name account_map_acc) + account_map + account_map + +(** Compute the staking rights for [current_cycle + + consensus_rights_delay + 1] and save them into + [account.frozen_rights] for each delegate. *) +let compute_future_frozen_rights block account_map = + let open Lwt_result_syntax in + String.Map.fold_es + (fun key acc acc_map -> + match acc.delegate with + | None -> return acc_map + | Some delegate_name -> + let delegate_pkh = + match String.Map.find delegate_name account_map with + | None -> + fail_account_not_found + "update_frozen_rights_cycle" + delegate_name + | Some delegate -> delegate.pkh + in + if delegate_pkh = acc.pkh then + (* Account is a delegate *) + let current_cycle = Block.current_cycle block in + (* Check the rights of current cycle. *) + let current_rights_state = + CycleMap.find (Block.current_cycle block) acc.frozen_rights + |> Option.value ~default:Tez.zero + in + let* current_rights_rpc = + Context.Delegate.initial_frozen_deposits (B block) acc.pkh + in + let* () = + Assert.equal_tez + ~loc:__LOC__ + current_rights_state + current_rights_rpc + in + (* Fill in the rights for future cycle. *) + let* deactivated = Context.Delegate.deactivated (B block) acc.pkh in + if deactivated then return acc_map + else + let future_cycle = + Cycle.add + current_cycle + (block.constants.consensus_rights_delay + 1) + in + let frozen_rights = + CycleMap.add + future_cycle + (current_total_frozen_deposits_with_limits acc) + acc.frozen_rights + in + return (String.Map.add key {acc with frozen_rights} acc_map) + else return acc_map) + account_map + account_map diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.ml new file mode 100644 index 0000000000000000000000000000000000000000..40fce015234a35bce17d687b5027c2ca412d6bcc --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.ml @@ -0,0 +1,289 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module handles the logic of flags for AI/AS in the [State] *) + +open State +open State_account + +module AI_Activation = struct + (** This module is responsible for the field [state.ai_activation_cycle], + which depends on three protocol parameters: + [adaptive_issuance.force_activation], [adaptive_issuance.activation_vote_enable], and + [adaptive_issuance.launch_ema_threshold]. *) + + (** AI can be activated with both flags set to false if the threshold is set to 0. + If the vote is enabled, but the threshold is above the maximum EMA, then the vote + cannot trigger the activation. *) + let enabled state = + state.constants.adaptive_issuance.force_activation + || (state.constants.adaptive_issuance.activation_vote_enable + && Compare.Int32.( + state.constants.adaptive_issuance.launch_ema_threshold + <= Protocol.Per_block_votes_repr.Internal_for_tests.ema_max)) + || Compare.Int32.( + state.constants.adaptive_issuance.launch_ema_threshold = 0l) + + let set_activation_cycle block state block_launch_cycle = + let current_cycle = Block.current_cycle block in + let offset = + if state.constants.adaptive_issuance.force_activation then 0 + else + 1 + state.constants.consensus_rights_delay + + Protocol.Constants_repr.max_slashing_period + in + assert ( + Protocol.Alpha_context.Cycle.( + add current_cycle offset = block_launch_cycle)) ; + {state with ai_activation_cycle = Some block_launch_cycle} + + (** Check the activation_cycle is only ever set once. + Run every block *) + let check_activation_cycle block state = + let open Lwt_result_syntax in + let open Protocol.Alpha_context in + let* block_launch_cycle = + Context.get_adaptive_issuance_launch_cycle (B block) + in + match (enabled state, state.ai_activation_cycle, block_launch_cycle) with + | _, None, None -> return state + | true, Some x, Some y -> + (* Activation cycle cannot be changed *) + if Cycle.(x = y) then return state else assert false + | _, Some _, None -> (* Activation cycle cannot be unset *) assert false + | false, _, Some _ -> + (* AI cannot be activated if [enabled] is false *) + assert false + | true, None, Some block_launch_cycle -> + return @@ set_activation_cycle block state block_launch_cycle +end + +module AI = struct + let enabled (block : Block.t) (state : State.t) = + match state.ai_activation_cycle with + | None -> false + | Some activation_cycle -> + let current_cycle = Block.current_cycle block in + Protocol.Alpha_context.Cycle.(current_cycle >= activation_cycle) +end + +module Autostake = struct + let enabled (block : Block.t) (state : State.t) = + (not (AI.enabled block state)) + && state.constants.adaptive_issuance.autostaking_enable + + let log_model_autostake name pkh old_cycle op ~optimal amount = + let open Protocol.Alpha_context in + Log.debug + "Model Autostaking: at end of cycle %a, %s(%a) to reach optimal stake %a \ + %s %a" + Cycle.pp + old_cycle + name + Signature.Public_key_hash.pp + pkh + Tez.pp + optimal + op + Tez.pp + (Tez_helpers.of_mutez amount) + + let apply_autostake (block : Block.t) ~name ~old_cycle + ({ + pkh; + contract = _; + delegate; + parameters = _; + liquid; + bonds = _; + frozen_deposits; + unstaked_frozen; + unstaked_finalizable; + staking_delegator_numerator = _; + staking_delegate_denominator = _; + frozen_rights = _; + slashed_cycles = _; + last_active_cycle; + } : + account_state) state = + let open Lwt_result_syntax in + (* TODO: use Protocol.Constants_storage.tolerated_inactivity_period *) + let tolerated_inactivity_period = + (2 * state.constants.consensus_rights_delay) + 1 + in + if Some name <> delegate then ( + Log.debug + "Model Autostaking: %s <> %s, noop@." + name + (Option.value ~default:"None" delegate) ; + return state) + else + let* ({grace_period; _} : Context.Delegate.info) = + Context.Delegate.info (B block) pkh + in + let model_grace_period = + Cycle.add last_active_cycle tolerated_inactivity_period + in + Log.debug + "Model Autostaking for %s: current cycle is %a, grace cycle is %a, \ + last_active_cycle is %a (grace %a)@." + name + Cycle.pp + old_cycle + Cycle.pp + grace_period + Cycle.pp + last_active_cycle + Cycle.pp + model_grace_period ; + + if Cycle.(old_cycle = model_grace_period) then ( + Log.debug "Model Autostaking: %s, deactivation -> unstaking all@." name ; + return + @@ update_map + ~f:(apply_unstake (Cycle.succ old_cycle) Tez.max_tez name) + state) + else if Cycle.(old_cycle > model_grace_period) then ( + Log.debug "Model Autostaking: %s, ignored (inactive)@." name ; + return state) + else + let*? current_liquid_delegated = liquid_delegated ~name state in + let current_frozen = Frozen_tez.total_current frozen_deposits in + let current_unstaked_frozen_delegated = + Unstaked_frozen.sum_current unstaked_frozen + in + let current_unstaked_final_delegated = + Unstaked_finalizable.total unstaked_finalizable + in + let power = + Tez.( + current_liquid_delegated +! current_frozen + +! current_unstaked_frozen_delegated + +! current_unstaked_final_delegated + |> to_mutez |> Z.of_int64) + in + let optimal = + Tez.of_z + (Z.cdiv + power + (Z.of_int (state.constants.limit_of_delegation_over_baking + 1))) + in + let autostaked = + Int64.(sub (Tez.to_mutez optimal) (Tez.to_mutez current_frozen)) + in + let state = State.apply_unslashable (Cycle.succ old_cycle) name state in + let state = State.apply_finalize name state in + (* stake or unstake *) + let new_state = + if autostaked > 0L then ( + log_model_autostake ~optimal name pkh old_cycle "stake" autostaked ; + State.apply_stake + Tez.(min liquid (of_mutez autostaked)) + (Cycle.succ old_cycle) + name + state) + else if autostaked < 0L then ( + log_model_autostake + ~optimal + name + pkh + old_cycle + "unstake" + (Int64.neg autostaked) ; + State.apply_unstake + (Cycle.succ old_cycle) + (Tez_helpers.of_mutez Int64.(neg autostaked)) + name + state) + else ( + log_model_autostake + ~optimal + name + pkh + old_cycle + "only finalize" + autostaked ; + state) + in + return new_state + + let run_at_cycle_end block state = + let open Lwt_result_syntax in + if enabled block state then + let current_cycle = Block.current_cycle block in + String.Map.fold_es + (fun name account state -> + apply_autostake block ~name ~old_cycle:current_cycle account state) + state.account_map + state + else return state +end + +module Delayed_slashing = struct + let enabled (state : State.t) = state.constants.adaptive_issuance.ns_enable + + (* Returns a pair, fst is the delayed slashes, snd is the slashes to apply now *) + let partition_slashes state current_cycle = + if not (enabled state) then ([], state.pending_slashes) + else + List.partition + (fun (_, Protocol.Denunciations_repr.{misbehaviour; _}) -> + let cycle = + Block.current_cycle_of_level + ~blocks_per_cycle: + state.constants + .Protocol.Alpha_context.Constants.Parametric.blocks_per_cycle + ~current_level: + (Protocol.Raw_level_repr.to_int32 misbehaviour.level) + in + Protocol.Alpha_context.Cycle.(cycle = current_cycle)) + state.pending_slashes +end + +module NS = struct + let enabled (block : Block.t) (state : State.t) = + AI.enabled block state && state.constants.adaptive_issuance.ns_enable + + let get_double_attestation_slashing_percentage all_denunciations_to_apply + block_before_slash state (misbehaviour : Protocol.Misbehaviour_repr.t) = + let open Lwt_result_wrap_syntax in + (* We need to get the block before the slash, because after the slash, + the context gets rid of the required Seed to recompute the rights + for the misbehaving delegates. *) + if not (enabled block_before_slash state) then + return + state.constants + .percentage_of_frozen_deposits_slashed_per_double_attestation + else + let* alpha_ctxt = Context.(get_alpha_ctxt (B block_before_slash)) in + let raw_ctxt = + Protocol.Alpha_context.Internal_for_tests.to_raw alpha_ctxt + in + let level = + Protocol.Level_repr.level_from_raw + ~cycle_eras:(Protocol.Raw_context.cycle_eras raw_ctxt) + misbehaviour.level + in + let delegates = + List.filter + (fun (_, (den : Protocol.Denunciations_repr.item)) -> + Compare.Int.( + Protocol.Misbehaviour_repr.compare misbehaviour den.misbehaviour + = 0)) + all_denunciations_to_apply + |> List.map fst + |> List.sort_uniq Signature.Public_key_hash.compare + in + let*@ _, pct = + Protocol.Slash_percentage.get + raw_ctxt + ~kind:misbehaviour.kind + ~level + delegates + in + return pct +end diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.mli b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.mli new file mode 100644 index 0000000000000000000000000000000000000000..af1808d26400fb612610a55caf4d1abff002a666 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.mli @@ -0,0 +1,80 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module handles the logic of flags for AI/AS in the [State] *) + +module AI_Activation : sig + (** This module takes care of the flags [force_activation] and + [activation_vote_enable], and updates and check the record field + [ai_activation_cycle] in the state. *) + + (** [AI_Activation] is enabled iff either of the above flags are set to true, + or the vote threshold is set to 0 (regardless of votes). + "Enabled" here means that AI *can* be activated (either by vote + or by force), but does not mean that AI is activated *) + val enabled : State.t -> bool + + (** Checks the [ai_activation_cycle] is set as expected. + Run at the beginning, and after every block to check the activation + cycle is set only once ever. *) + val check_activation_cycle : Block.t -> State.t -> State.t tzresult Lwt.t +end + +module AI : sig + (** This module only checks (for now) if AI is activated or not *) + + (** AI is enabled iff the activation cycle is set and passed *) + val enabled : Block.t -> State.t -> bool +end + +module Autostake : sig + (** This module takes care of autostaking when it is enabled *) + + (** Autostaking is enabled iff the flag [autostaking_enable] is true and + AI is not activated ([AI.enabled = false]). *) + val enabled : Block.t -> State.t -> bool + + (** Runs the autostake operations at cycle end. Does nothing if + [enabled = false]. *) + val run_at_cycle_end : Block.t -> State.t -> State.t tzresult Lwt.t +end + +module Delayed_slashing : sig + (** This module takes care of choosing the denunciations that need to be + applied at the end of a cycle. It depends on the flag [ns_enable]. *) + + (** [Delayed_slashing] is enabled iff [ns_enable = true]. *) + val enabled : State.t -> bool + + (** [partition_slashes s cycle] returns a pair [(l1,l2)] of lists of slashes, + partitioned from the [state.pending_slashes]. [l2] is the list of slashes to + apply at the end of the given [cycle], and [l1] is the rest (which should + usually replace [state.pending_slashes]) + *) + val partition_slashes : + State.t -> + Protocol.Alpha_context.Cycle.t -> + (Signature.Public_key_hash.t * Protocol.Denunciations_repr.item) list + * (Signature.Public_key_hash.t * Protocol.Denunciations_repr.item) list +end + +module NS : sig + (** This module takes care of the new adaptive slashing mechanism.*) + + (** It is enabled iff the flag [ns_enable] is set to true, and AI is + also enabled. *) + val enabled : Block.t -> State.t -> bool + + (** Whatever the value of the flag is, this function returns the + slashing value for a given double attestation *) + val get_double_attestation_slashing_percentage : + (Signature.public_key_hash * Protocol.Denunciations_repr.item) list -> + Block.t -> + State.t -> + Protocol.Misbehaviour_repr.t -> + Protocol.Percentage.t tzresult Lwt.t +end diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/test_tez.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.ml similarity index 68% rename from src/proto_019_PtParisB/lib_protocol/test/helpers/test_tez.ml rename to src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.ml index 7d523a82c98e4c800dce1e8812ca4c585d58b144..1be51c6b3a1e50c6d008a107ab59987d4f04db30 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/test_tez.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.ml @@ -26,9 +26,7 @@ open Protocol open Alpha_context open Environment - -(* This module wraps the errors from the protocol *) -open Tez +include Tez let ( +? ) t1 t2 = t1 +? t2 |> wrap_tzresult @@ -36,6 +34,8 @@ let ( -? ) t1 t2 = t1 -? t2 |> wrap_tzresult let ( *? ) t1 t2 = t1 *? t2 |> wrap_tzresult +let ( /? ) t1 t2 = t1 /? t2 |> wrap_tzresult + let ( +! ) t1 t2 = match t1 +? t2 with Ok r -> r | Error _ -> Pervasives.failwith "adding tez" @@ -59,10 +59,60 @@ let of_int x = | None -> invalid_arg "tez_of_int" | Some x -> x -let of_mutez_exn x = +let of_mutez x = match Tez.of_mutez x with None -> invalid_arg "tez_of_mutez" | Some x -> x let to_mutez = Tez.to_mutez +(* Should be the same as Tez.max_mutez *) let max_tez = match Tez.of_mutez Int64.max_int with None -> assert false | Some p -> p + +let of_z a = Z.to_int64 a |> Tez.of_mutez_exn + +let of_q ~round Q.{num; den} = + (match round with `Up -> Z.cdiv num den | `Down -> Z.div num den) |> of_z + +let to_z a = to_mutez a |> Z.of_int64 + +let ratio num den = + Q.make (Z.of_int64 (to_mutez num)) (Z.of_int64 (to_mutez den)) + +let mul_q tez portion = + let tez_z = to_mutez tez |> Z.of_int64 in + Q.(mul portion ~$$tez_z) + +module Compare = Tez + +module Ez_tez = struct + (** Aliases for tez values *) + type tez_quantity = + | Half + | All + | All_but_one + | Nothing + | Max_tez + | Amount of t + + let tez_quantity_pp fmt value = + let s = + match value with + | Nothing -> "Zero" + | All -> "All" + | All_but_one -> "All but 1µꜩ" + | Half -> "Half" + | Max_tez -> "Maximum" + | Amount a -> Format.asprintf "%aꜩ" pp a + in + Format.fprintf fmt "%s" s + + (* [all] is the amount returned when [qty = All]. If [qty = Half], returns half of that. *) + let quantity_to_tez all qty = + match qty with + | Nothing -> zero + | All -> all + | All_but_one -> if equal all zero then zero else all -! one_mutez + | Half -> all /! 2L + | Max_tez -> max_tez + | Amount a -> a +end diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.mli b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.mli new file mode 100644 index 0000000000000000000000000000000000000000..57d5501364efaa1d9ebc0395918b8184860dca29 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.mli @@ -0,0 +1,89 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** This module wraps the errors from the protocol and provides some helpful + functions manipulating Tez. *) +type t = Protocol.Alpha_context.Tez.t + +val zero : t + +val one_mutez : t + +val one_cent : t + +val fifty_cents : t + +val one : t + +(* Same as max_mutez *) +val max_tez : t + +val equal : t -> t -> bool + +val ( -? ) : t -> t -> t tzresult + +val sub_opt : t -> t -> t option + +val ( +? ) : t -> t -> t tzresult + +val ( *? ) : t -> int64 -> t tzresult + +val ( /? ) : t -> int64 -> t tzresult + +(* These operators can raise exceptions *) +val ( -! ) : t -> t -> t + +val ( +! ) : t -> t -> t + +val ( *! ) : t -> int64 -> t + +val ( /! ) : t -> int64 -> t + +val to_mutez : t -> int64 + +(* Is actually of_mutez_exn *) +val of_mutez : int64 -> t + +val min : t -> t -> t + +module Compare : Compare.S with type t := t + +val pp : Format.formatter -> t -> unit + +val to_string : t -> string + +(* Helper functions, not exported from the protocol *) +val ratio : t -> t -> Q.t + +val mul_q : t -> Q.t -> Q.t + +val of_int : int -> t + +val of_q : round:[`Down | `Up] -> Q.t -> t + +val of_z : Z.t -> t + +val to_z : t -> Z.t + +(** Functions to manipulate Tez in a high level way *) +module Ez_tez : sig + (** Aliases for tez values *) + type tez_quantity = + | Half + | All + | All_but_one + | Nothing + | Max_tez + | Amount of t + + val tez_quantity_pp : Format.formatter -> tez_quantity -> unit + + (** [quantity_to_tez max qty] returns a tez value corresponding to the given + [qty]. If [qty] is [All], then returns [max]. If [qty] is [All_but_one], + returns [max - one_mutez]. *) + val quantity_to_tez : t -> tez_quantity -> t +end diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_staking_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_staking_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..141a2c17c80add10240af227ef495067b4ba73bf --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/tez_staking_helpers.ml @@ -0,0 +1,567 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** [Tez_staking_helpers] defines different kinds of tez Modules that + manipulate them in different ways. They involve more complicated operations, + as they are related to staking, thus are represented as partial amounts, + and are related to pseudotokens. *) + +module Cycle = Protocol.Alpha_context.Cycle + +module Tez = struct + include Tez_helpers + include Tez_helpers.Compare +end + +(** Representation of Tez with non integer values *) +module Partial_tez = struct + include Q + + let of_tez a = Tez.to_mutez a |> of_int64 + + let to_tez_rem {num; den} = + let tez, rem = Z.div_rem num den in + (Tez.of_z tez, rem /// den) + + let to_tez ~round = Tez.of_q ~round + + let get_rem a = snd (to_tez_rem a) + + let pp fmt a = + let tez, rem = to_tez_rem a in + (* If rem = 0, we keep the (+ 0), to indicate that it's a partial tez *) + Format.fprintf fmt "%a ( +%aµꜩ )" Tez.pp tez Q.pp_print rem +end + +(** [Frozen_tez] represents frozen stake and frozen unstaked funds. + Properties: + - sum of all current partial tez is an integer + - Can only add integer amounts + - Can always subtract integer amount (if lower than frozen amount) + - If subtracting partial amount, must be the whole frozen amount (for given contract). + The remainder is then distributed equally amongst remaining accounts, to keep property 1. + - All entries of current are positive, non zero. +*) +module Frozen_tez = struct + (* The map in current maps the stakers' name with their staked value. + It contains only delegators of the delegate which owns the frozen tez *) + type t = { + delegate : string; + initial : Tez.t; + self_current : Tez.t; + co_current : Partial_tez.t String.Map.t; + } + + let pp fmt {delegate; initial; self_current; co_current} = + Format.fprintf + fmt + "Delegate: %s, Initial: %a, Self_current: %a, Co_current: %a" + delegate + Tez.pp + initial + Tez.pp + self_current + (fun fmt -> + String.Map.iter (fun k v -> + Format.fprintf fmt "%s: %a, " k Partial_tez.pp v)) + co_current + + let zero = + { + delegate = ""; + initial = Tez.zero; + self_current = Tez.zero; + co_current = String.Map.empty; + } + + let init amount account delegate = + if account = delegate then + { + delegate; + initial = amount; + self_current = amount; + co_current = String.Map.empty; + } + else + { + delegate; + initial = amount; + self_current = Tez.zero; + co_current = String.Map.singleton account (Partial_tez.of_tez amount); + } + + let union a b = + assert (a.delegate = b.delegate) ; + { + delegate = a.delegate; + initial = Tez.(a.initial +! b.initial); + self_current = Tez.(a.self_current +! b.self_current); + co_current = + String.Map.union + (fun _ x y -> Some Partial_tez.(x + y)) + a.co_current + b.co_current; + } + + let get account frozen_tez = + if account = frozen_tez.delegate then + Partial_tez.of_tez frozen_tez.self_current + else + match String.Map.find account frozen_tez.co_current with + | None -> Partial_tez.zero + | Some p -> p + + let total_co_current_q co_current = + String.Map.fold + (fun _ x acc -> Partial_tez.(x + acc)) + co_current + Partial_tez.zero + + let total_co_current t = + let r = total_co_current_q t.co_current in + let tez, rem = Partial_tez.to_tez_rem r in + assert (Q.(equal rem zero)) ; + tez + + let total_current t = Tez.(t.self_current +! total_co_current t) + + let total_current_with_limits ~limit_of_staking_over_baking t = + let max_co_current = + Tez.mul_q t.self_current limit_of_staking_over_baking + |> Tez.of_q ~round:`Down + in + let co_current = Tez.min (total_co_current t) max_co_current in + Tez.(t.self_current +! co_current) + + (* Precondition: 0 <= quantity < 1 && co_current + quantity is int *) + let add_q_to_all_co_current quantity co_current = + let s = total_co_current_q co_current in + if Q.(equal quantity zero) then co_current + else + let f p_amount = + let q = Q.div p_amount s in + Partial_tez.add p_amount (Q.mul quantity q) + in + String.Map.map f co_current + + (* For rewards, distribute equally *) + let add_tez_to_all_current ~edge ~limit tez a = + let total_current = total_current a in + let total_current_with_limit = + Tez.( + mul_q a.self_current Q.(add one limit) + |> of_q ~round:`Up |> min total_current) + in + let self_portion = Tez.ratio a.self_current total_current_with_limit in + (* Baker's advantage for the mutez *) + let self_quantity = Tez.mul_q tez self_portion |> Tez.of_q ~round:`Up in + let remains = Tez.(tez -! self_quantity) in + (* Baker's edge. Round up for the baker's advantage again *) + let bakers_edge = Tez.mul_q remains edge |> Tez.of_q ~round:`Up in + let self_quantity = Tez.(self_quantity +! bakers_edge) in + (* The remains are distributed equally *) + let co_quantity = Partial_tez.of_tez Tez.(tez -! self_quantity) in + let co_current = add_q_to_all_co_current co_quantity a.co_current in + {a with co_current; self_current = Tez.(a.self_current +! self_quantity)} + + (* For slashing, slash equally *) + let sub_tez_from_all_current ~limit tez a = + let total_current = total_current a in + let total_current_with_limit = + Tez.( + mul_q a.self_current Q.(add one limit) + |> of_q ~round:`Up |> min total_current) + in + let self_portion = Tez.ratio a.self_current total_current_with_limit in + let self_quantity = Tez.mul_q tez self_portion |> Tez.of_q ~round:`Up in + let self_current = + if Tez.(self_quantity >= a.self_current) then Tez.zero + else Tez.(a.self_current -! self_quantity) + in + let co_quantity = Tez.(tez -! self_quantity) in + let s = total_co_current_q a.co_current in + if Partial_tez.(geq (of_tez co_quantity) s) then + ( {a with self_current; co_current = String.Map.empty}, + self_quantity, + co_quantity ) + else + let f p_amount = + let q = Q.div p_amount s in + Partial_tez.sub p_amount (Tez.mul_q co_quantity q) + (* > 0 *) + in + ( {a with self_current; co_current = String.Map.map f a.co_current}, + self_quantity, + co_quantity ) + + (* Adds frozen to account. Happens each stake in frozen deposits *) + let add_current_q amount account a = + if account = a.delegate then ( + let amount, rem = Partial_tez.to_tez_rem amount in + assert (Q.(equal rem zero)) ; + {a with self_current = Tez.(a.self_current +! amount)}) + else + { + a with + co_current = + String.Map.update + account + (function + | None -> Some amount | Some q -> Some Partial_tez.(add q amount)) + a.co_current; + } + + let add_current amount account a = + add_current_q (Partial_tez.of_tez amount) account a + + let add_self_current amount a = + let self_current = Tez.(a.self_current +! amount) in + {a with self_current} + + (* Adds frozen to account. Happens each unstake to unstaked frozen deposits *) + let add_init amount account a = union a (init amount account a.delegate) + + (* Allows amount greater than current frozen amount. + Happens each unstake in frozen deposits *) + let sub_current amount account a = + if account = a.delegate then + let amount = Tez.min amount a.self_current in + ({a with self_current = Tez.(a.self_current -! amount)}, amount) + else + match String.Map.find account a.co_current with + | None -> (a, Tez.zero) + | Some frozen -> + let amount_q = Partial_tez.of_tez amount in + if Q.(geq amount_q frozen) then + let removed, remainder = Partial_tez.to_tez_rem frozen in + let co_current = String.Map.remove account a.co_current in + let co_current = add_q_to_all_co_current remainder co_current in + ({a with co_current}, removed) + else + let co_current = + String.Map.add account Q.(frozen - amount_q) a.co_current + in + ({a with co_current}, amount) + + (* Remove a partial amount from the co frozen tez table. *) + let sub_current_q amount_q account a = + if account = a.delegate then assert false + else + match String.Map.find account a.co_current with + | None -> assert false + | Some frozen -> + if Q.(geq amount_q frozen) then + let co_current = String.Map.remove account a.co_current in + {a with co_current} + else + let co_current = + String.Map.add account Q.(frozen - amount_q) a.co_current + in + {a with co_current} + + let sub_current_and_init amount account a = + let a, amount = sub_current amount account a in + ({a with initial = Tez.(a.initial -! amount)}, amount) + + let slash ~limit cst base_amount (pct : Protocol.Percentage.t) a = + Log.info + "Slashing frozen tez for delegate %s with percentage %a" + a.delegate + Q.pp_print + @@ Protocol.Percentage.to_q pct ; + let pct_q = Protocol.Percentage.to_q pct in + let total_current = total_current a in + let slashed_amount = + Tez.mul_q base_amount pct_q + |> Tez.of_q ~round:`Down |> Tez.min total_current + in + let a, burnt_amount, rewarded_amount = + if total_current > Tez.zero then + let a, slashed_baker, slashed_staker = + sub_tez_from_all_current slashed_amount ~limit a + in + let rat = + cst.Protocol.Alpha_context.Constants.Parametric.adaptive_issuance + .global_limit_of_staking_over_baking + 2 + in + let rewarded_baker = + Tez.mul_q slashed_baker Q.(1 // rat) |> Tez.of_q ~round:`Down + in + + let rewarded_staker = + Tez.mul_q slashed_staker Q.(1 // rat) |> Tez.of_q ~round:`Down + in + let rewarded_amount = Tez.(rewarded_baker +! rewarded_staker) in + + let burnt_amount = Tez.(slashed_amount -! rewarded_amount) in + (a, burnt_amount, rewarded_amount) + else (a, Tez.zero, Tez.zero) + in + Log.info + "Total current: %a, slashed amount: %a, rewarded amount: %a, burnt \ + amount: %a" + Tez.pp + total_current + Tez.pp + slashed_amount + Tez.pp + rewarded_amount + Tez.pp + burnt_amount ; + (a, burnt_amount, rewarded_amount) +end + +(** Representation of Unstaked frozen deposits *) +module Unstaked_frozen = struct + type r = { + cycle : Cycle.t; + (* initial total requested amount (slash ∝ initial) *) + initial : Tez.t; + (* current amount, slashes applied here *) + current : Tez.t; + (* initial requests, don't apply slash unless finalize or balance query *) + requests : Tez.t String.Map.t; + (* slash pct memory for requests *) + slash_pct : int; + } + + type t = r list + + type get_info = {cycle : Cycle.t; request : Tez.t; current : Tez.t} + + type get_info_list = get_info list + + type finalizable_info = { + amount : Tez.t; + slashed_requests : Tez.t String.Map.t; + } + + let zero = [] + + let init_r cycle request account = + { + cycle; + initial = request; + current = request; + requests = String.Map.singleton account request; + slash_pct = 0; + } + + let apply_slash_to_request slash_pct amount = + let slashed_amount = + Tez.mul_q amount Q.(slash_pct // 100) |> Tez.of_q ~round:`Up + in + Tez.(amount -! slashed_amount) + + let apply_slash_to_current cst slash_pct initial current = + let slashed_amount = + Tez.mul_q initial Q.(slash_pct // 100) + |> Tez.of_q ~round:`Down |> Tez.min current + in + let rat = + cst.Protocol.Alpha_context.Constants.Parametric.adaptive_issuance + .global_limit_of_staking_over_baking + 2 + in + let rewarded_amount = + Tez.mul_q slashed_amount Q.(1 // rat) |> Tez.of_q ~round:`Down + in + let burnt_amount = Tez.(slashed_amount -! rewarded_amount) in + let actual_slashed_amount = Tez.(rewarded_amount +! burnt_amount) in + let remaining = + Tez.sub_opt current actual_slashed_amount + |> Option.value ~default:Tez.zero + in + (remaining, burnt_amount, rewarded_amount) + + let remove_zeros (a : t) : t = + List.filter (fun ({current; _} : r) -> Tez.(current > zero)) a + + let get account unstaked : get_info_list = + List.filter_map + (fun {cycle; requests; slash_pct; _} -> + String.Map.find account requests + |> Option.map (fun request -> + { + cycle; + request; + current = apply_slash_to_request slash_pct request; + })) + unstaked + + let get_total account unstaked = + get account unstaked + |> List.fold_left + (fun acc ({current; _} : get_info) -> Tez.(acc +! current)) + Tez.zero + + let sum_current unstaked = + List.fold_left + (fun acc ({current; _} : r) -> Tez.(acc +! current)) + Tez.zero + unstaked + + (* Happens each unstake operation *) + let rec add_unstake cycle amount account : t -> t = function + | [] -> [init_r cycle amount account] + | ({cycle = c; requests; initial; current; slash_pct} as h) :: t -> + let open Tez in + if Cycle.equal c cycle then ( + assert (Int.equal slash_pct 0) ; + { + cycle; + initial = initial +! amount; + current = current +! amount; + slash_pct; + requests = + String.Map.update + account + (function + | None -> Some amount | Some x -> Some Tez.(x +! amount)) + requests; + } + :: t) + else h :: add_unstake cycle amount account t + + (* Happens in stake from unstake *) + let sub_unstake amount account : r -> r = + fun {cycle; requests; initial; current; slash_pct} -> + assert (slash_pct = 0) ; + let open Tez in + { + cycle; + initial = initial -! amount; + current = current -! amount; + slash_pct; + requests = + String.Map.update + account + (function + | None -> + assert (Tez.(amount = zero)) ; + None + | Some x -> + if Tez.(x = amount) then None else Some Tez.(x -! amount)) + requests; + } + + (* Makes given cycle finalizable (and unslashable) *) + let rec pop_cycle cycle : t -> finalizable_info * t = function + | [] -> ({amount = Tez.zero; slashed_requests = String.Map.empty}, []) + | ({cycle = c; requests; initial = _; current; slash_pct} as h) :: t -> + if Cycle.(c = cycle) then + let amount = current in + let slashed_requests = + String.Map.map (apply_slash_to_request slash_pct) requests + in + ({amount; slashed_requests}, t) + else if Cycle.(c < cycle) then + Stdlib.failwith + "Unstaked_frozen: found unfinalized cycle before given [cycle]. \ + Make sure to call [apply_unslashable] every cycle" + else + let info, rest = pop_cycle cycle t in + (info, h :: rest) + + let slash cst ~slashable_deposits_period slashed_cycle pct_times_100 a = + remove_zeros a + |> List.map + (fun + ({cycle; requests = _; initial; current; slash_pct = old_slash_pct} + as r) + -> + if + Cycle.( + cycle > slashed_cycle + || add cycle slashable_deposits_period < slashed_cycle) + then (r, (Tez.zero, Tez.zero)) + else + let new_current, burnt, rewarded = + apply_slash_to_current cst pct_times_100 initial current + in + let slash_pct = min 100 (pct_times_100 + old_slash_pct) in + ({r with slash_pct; current = new_current}, (burnt, rewarded))) + |> List.split +end + +(** Representation of unstaked finalizable tez *) +module Unstaked_finalizable = struct + (* Slashing might put inaccessible tez in this container: they are represented in the remainder. + They still count towards the total supply, but are currently owned by noone. + At most one mutez per unstaking account per slashed cycle *) + type t = {map : Tez.t String.Map.t; remainder : Tez.t} + + let zero = {map = String.Map.empty; remainder = Tez.zero} + + (* Called when unstaked frozen for some cycle becomes finalizable *) + let add_from_poped_ufd + ({amount; slashed_requests} : Unstaked_frozen.finalizable_info) + {map; remainder} = + let total_requested = + String.Map.fold (fun _ x acc -> Tez.(x +! acc)) slashed_requests Tez.zero + in + let remainder = Tez.(remainder +! amount -! total_requested) in + let map = + String.Map.union (fun _ a b -> Some Tez.(a +! b)) map slashed_requests + in + {map; remainder} + + let total {map; remainder} = + String.Map.fold (fun _ x acc -> Tez.(x +! acc)) map remainder + + let get account {map; _} = + match String.Map.find account map with None -> Tez.zero | Some x -> x +end + +(** Pseudotoken helpers *) +let tez_to_pseudo ~round amount staking_delegate_denominator frozen_deposits = + let total_q = Frozen_tez.(total_co_current_q frozen_deposits.co_current) in + let total, rem = Partial_tez.to_tez_rem total_q in + assert (Q.(equal rem zero)) ; + if Tez.(equal total zero) then Tez.to_z amount + else + let r = Tez.ratio amount total in + let p = Q.(r * of_bigint staking_delegate_denominator) in + Tez.(of_q ~round p |> to_z) + +let pseudo_to_partial_tez amount_pseudo staking_delegate_denominator + frozen_deposits = + let total_q = Frozen_tez.(total_co_current_q frozen_deposits.co_current) in + let total, rem = Partial_tez.to_tez_rem total_q in + assert (Q.(equal rem zero)) ; + if Z.(equal staking_delegate_denominator zero) then Q.of_bigint amount_pseudo + else + let q = Q.(amount_pseudo /// staking_delegate_denominator) in + Tez.mul_q total q + +(* tez_q <= amount *) +let stake_values_real amount staking_delegate_denominator frozen_deposits = + let pseudo = + tez_to_pseudo + ~round:`Down + amount + staking_delegate_denominator + frozen_deposits + in + let tez_q = + pseudo_to_partial_tez pseudo staking_delegate_denominator frozen_deposits + in + (pseudo, tez_q) + +(* returned_amount <= amount *) +let unstake_values_real amount staking_delegate_denominator frozen_deposits = + let pseudo = + tez_to_pseudo ~round:`Up amount staking_delegate_denominator frozen_deposits + in + let tez_q = + pseudo_to_partial_tez pseudo staking_delegate_denominator frozen_deposits + in + if Tez.equal (Tez.of_q ~round:`Down tez_q) amount then (pseudo, tez_q) + else + let pseudo = Z.(pseudo - one) in + ( pseudo, + pseudo_to_partial_tez pseudo staking_delegate_denominator frozen_deposits + ) diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/tezt_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/tezt_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..e075dbbca559c8dc44cfff10c2801f0612918e30 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/tezt_helpers.ml @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Test registration *) + +(** Registers a test. The protocol's name is added to the title and + tags. File-specific title prefix and tags can also be specified. *) +let register_test ~__FILE__ ?(file_tags = []) ~title ?(additional_tags = []) + ?(slow = false) f = + let tags = + let tags = file_tags @ additional_tags in + if slow then Tezos_test_helpers.Tag.slow :: tags else tags + in + Tezt_tezos.Protocol.register_test + ~__FILE__ + ~title + ~tags + ~uses:(fun _ -> []) + ~uses_node:false + ~uses_client:false + ~uses_admin_client:false + (fun _protocol -> f ()) + [Paris] + +(** Same as [register_test], but for a test function returning [unit + tzresult Lwt.t]. If the result is an error, the test fails. *) +let register_test_es ~__FILE__ ?file_tags ~title ?additional_tags ?slow f = + register_test ~__FILE__ ?file_tags ~title ?additional_tags ?slow @@ fun () -> + let* r = f () in + match r with + | Ok () -> Lwt.return_unit + | Error err -> + let* () = Tezos_base_unix.Internal_event_unix.close () in + Test.fail "@\n%a@." pp_print_trace err diff --git a/src/proto_019_PtParisB/lib_protocol/test/helpers/transfers.ml b/src/proto_019_PtParisB/lib_protocol/test/helpers/transfers.ml index f04fab9a7c8e5690eb23c491bdf469921f18f425..864b70be878abc1b9953e6cb57d038f51eb9fbe9 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/helpers/transfers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/helpers/transfers.ml @@ -25,7 +25,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee = Tez.zero) ?expect_apply_failure src dst amount = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_baking.ml index 4d49da6a4dd0ae0ef7ee47123f8e29d8e555c112..d562dea935c9bda718f46072cb89d1accd9a310d 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_baking.ml @@ -118,7 +118,7 @@ let test_voting_power_cache () = assert_voting_power ~loc:__LOC__ initial_voting_power_at_genesis genesis in let rewards_after_one_voting_period = - Test_tez.(baking_reward *! Int64.pred (blocks_per_voting_periods 1)) + Tez_helpers.(baking_reward *! Int64.pred (blocks_per_voting_periods 1)) in let expected_delta_voting_power_after_one_voting_period = Tez.to_mutez rewards_after_one_voting_period @@ -138,7 +138,7 @@ let test_voting_power_cache () = block in let rewards_after_two_voting_periods = - Test_tez.(baking_reward *! Int64.pred (blocks_per_voting_periods 2)) + Tez_helpers.(baking_reward *! Int64.pred (blocks_per_voting_periods 2)) in let expected_delta_voting_power_after_two_voting_periods = Tez.to_mutez rewards_after_two_voting_periods @@ -167,7 +167,7 @@ let test_basic_baking_reward () = Context.Delegate.current_frozen_deposits (B b) baker_pkh in let* br = Context.get_baking_reward_fixed_portion (B b) in - let open Test_tez in + let open Tez_helpers in let expected_initial_balance = bal +! frozen_deposit -! br in Assert.equal_tez ~loc:__LOC__ @@ -249,7 +249,7 @@ let test_rewards_block_and_payload_producer () = block producer, in our case, [baker_b2]. [baker_b2] gets the baking reward plus the fee for the transaction [tx]. *) let expected_balance = - let open Test_tez in + let open Tez_helpers in Account.default_initial_balance -! frozen_deposit +! baking_reward +! bonus_reward +! reward_for_b1 +! fee in @@ -291,7 +291,7 @@ let test_rewards_block_and_payload_producer () = else Tez.zero in let expected_balance = - let open Test_tez in + let open Tez_helpers in Account.default_initial_balance +! baking_reward -! frozen_deposit +! reward_for_b1 +! fee in @@ -309,7 +309,7 @@ let test_rewards_block_and_payload_producer () = else Tez.zero in let expected_balance' = - let open Test_tez in + let open Tez_helpers in Account.default_initial_balance +! bonus_reward +! reward_for_b1' -! frozen_deposits' in @@ -349,7 +349,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = Context.Delegate.current_frozen_deposits (B b1) pkh1 in let expected_bal = - Test_tez.( + Tez_helpers.( Tez.of_mutez_exn initial_bal1 +! baking_reward_fixed_portion -! frozen_deposit) in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_consensus_key.ml index 6278c4b1d45a7826933614b4e91a6e107eacd8bc..a3705ebaa03ffcaed697118706821779f9053730 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -178,7 +178,7 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = in let expected_final_balance = if exclude_ck then Tez.zero - else Tez.(max one) Test_tez.(delegate_balance /! 100L) + else Tez.(max one) Tez_helpers.(delegate_balance /! 100L) in drain_delegate ~policy diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_deactivation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_deactivation.ml index 98f9a8a70293028fc677fe6bc7041d1e145cbb85..f24faa3c7088df4ba1e36f350f15989a191607fe 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_deactivation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_deactivation.ml @@ -36,7 +36,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers (** Check that [Delegate.staking_balance] is the same as [Delegate.full_balance] (this is not true in general, but in these tests it is because they only deal diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_delegation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_delegation.ml index 47899ef30f17142049e3a2dedd97ff610c57af84..3df190603e0606dc24e7c31a7e6f998e68631c42 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_delegation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_delegation.ml @@ -38,7 +38,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers (*****************************************************************************) (* Bootstrap contracts @@ -425,7 +425,8 @@ let tests_bootstrap_contracts = Tztest.tztest "bootstrap manager can be delegate (init origination, large fee)" `Quick - (delegate_to_bootstrap_by_origination ~fee:(Test_tez.of_int 10_000_000)); + (delegate_to_bootstrap_by_origination + ~fee:(Tez_helpers.of_int 10_000_000)); Tztest.tztest "originated bootstrap contract can be undelegated" `Quick diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_attestation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_attestation.ml index c905e9bbfe615f8b8749d1db118fcb6ab66a9493..67edd5683eaebbe598d24355669b20695cc29679 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_attestation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_attestation.ml @@ -52,17 +52,17 @@ let block_fork ?excluding b = (blk_a, blk_b) (* Checks that there is exactly one denunciation for the given delegate *) -let check_denunciations ~(level : Raw_level.t) b delegate = +let check_denunciations ~loc b delegate duplicate_op = let open Lwt_result_syntax in let* denunciations = Context.get_denunciations (B b) in match denunciations with - | [(d, item)] when Signature.Public_key_hash.equal d delegate -> - assert (item.Denunciations_repr.misbehaviour.kind = Double_attesting) ; - assert ( - Raw_level_repr.to_int32 item.Denunciations_repr.misbehaviour.level - = Raw_level.to_int32 level) ; - return_unit - | _ -> assert false + | [(d, item)] -> + let* () = Assert.equal_pkh ~loc d delegate in + Slashing_helpers.Misbehaviour_repr.check_from_duplicate_operation + ~loc + item.misbehaviour + duplicate_op + | _ -> Test.fail ~__LOC__:loc "expected exactly one denunciation" let check_empty_denunciations b = let open Lwt_result_syntax in @@ -131,9 +131,7 @@ let test_valid_double_attestation_evidence () = let* full_balance = Context.Delegate.full_balance (B blk_a) baker in let* () = check_empty_denunciations blk_a in let* blk_final = Block.bake ~policy:(By_account baker) ~operation blk_a in - (* Check that parts of the frozen deposits are slashed *) - let*? double_level = Context.get_level (B blk_a) in - let* () = check_denunciations ~level:double_level blk_final delegate in + let* () = check_denunciations ~loc:__LOC__ blk_final delegate attestation_a in let* frozen_deposits_before = Context.Delegate.current_frozen_deposits (B blk_a) delegate in @@ -155,6 +153,8 @@ let test_valid_double_attestation_evidence () = frozen_deposits_right_after frozen_deposits_before in + (* Check that the right portion of the frozen deposits is slashed at + the end of the cycle. *) let* blk_eoc, metadata, _ = Block.bake_until_n_cycle_end_with_metadata ~policy:(By_account baker) @@ -166,14 +166,16 @@ let test_valid_double_attestation_evidence () = let* frozen_deposits_after = Context.Delegate.current_frozen_deposits (B blk_eoc) delegate in - let frozen_deposits_after = Test_tez.(frozen_deposits_after -! autostaked) in + let frozen_deposits_after = + Tez_helpers.(frozen_deposits_after -! autostaked) + in let one_minus_p = Percentage.neg constants.percentage_of_frozen_deposits_slashed_per_double_attestation in let {Q.num; den} = Percentage.to_q one_minus_p in let expected_frozen_deposits_after = - Test_tez.(frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) + Tez_helpers.(frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) in let* () = Assert.equal_tez @@ -195,12 +197,12 @@ let test_valid_double_attestation_evidence () = (Int64.of_int constants.adaptive_issuance.global_limit_of_staking_over_baking) in - let evidence_reward = Test_tez.(frozen_deposits_after /! divider) in - let expected_reward = Test_tez.(baking_reward +! evidence_reward) in + let evidence_reward = Tez_helpers.(frozen_deposits_after /! divider) in + let expected_reward = Tez_helpers.(baking_reward +! evidence_reward) in let* full_balance_with_rewards = Context.Delegate.full_balance (B blk_eoc) baker in - let real_reward = Test_tez.(full_balance_with_rewards -! full_balance) in + let real_reward = Tez_helpers.(full_balance_with_rewards -! full_balance) in Assert.equal_tez ~loc:__LOC__ expected_reward real_reward (** Check that a double (pre)attestation evidence with equivalent @@ -321,10 +323,7 @@ let test_two_double_attestation_evidences_leadsto_no_bake () = frozen_deposits_right_after in let* is_forbidden = - Context.Delegate.is_forbidden - ~policy:(Block.By_account baker) - (B blk_with_evidence2) - delegate + Context.Delegate.is_forbidden (B blk_with_evidence2) delegate in let* () = Assert.is_true ~loc:__LOC__ is_forbidden in let*! b = Block.bake ~policy:(By_account delegate) blk_with_evidence2 in @@ -346,11 +345,12 @@ let test_two_double_attestation_evidences_leadsto_no_bake () = let* frozen_deposits_after = Context.Delegate.current_frozen_deposits (B b) delegate in - let frozen_deposits_after = Test_tez.(frozen_deposits_after -! autostaked) in + let frozen_deposits_after = + Tez_helpers.(frozen_deposits_after -! autostaked) + in let* base_reward = Context.get_baking_reward_fixed_portion (B genesis) in let* to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy:(By_account baker) (B b) (Block.current_cycle b) delegate @@ -360,7 +360,7 @@ let test_two_double_attestation_evidences_leadsto_no_bake () = that's left *) Assert.equal_tez ~loc:__LOC__ - Test_tez.(base_reward -! to_liquid) + Tez_helpers.(base_reward -! to_liquid) frozen_deposits_after (** Say a delegate double-attests twice in a cycle, @@ -434,10 +434,7 @@ let test_two_double_attestation_evidences_staggered () = frozen_deposits_after ; let* () = Assert.not_equal_tez ~loc:__LOC__ Tez.zero frozen_deposits_after in let* is_forbidden = - Context.Delegate.is_forbidden - ~policy:(Block.By_account baker) - (B blk_with_evidence2) - delegate + Context.Delegate.is_forbidden (B blk_with_evidence2) delegate in let* () = Assert.is_true ~loc:__LOC__ is_forbidden in let*! b = Block.bake ~policy:(By_account delegate) blk_with_evidence2 in @@ -510,10 +507,7 @@ let test_two_double_attestation_evidences_consecutive_cycles () = frozen_deposits_after ; let* () = Assert.not_equal_tez ~loc:__LOC__ Tez.zero frozen_deposits_after in let* is_forbidden = - Context.Delegate.is_forbidden - ~policy:(Block.By_account baker) - (B blk_with_evidence2) - delegate + Context.Delegate.is_forbidden (B blk_with_evidence2) delegate in let* () = Assert.is_true ~loc:__LOC__ is_forbidden in let*! b = Block.bake ~policy:(By_account delegate) blk_with_evidence2 in @@ -733,7 +727,7 @@ let test_freeze_more_with_low_balance = (B genesis) (Contract.Implicit account1) (Contract.Implicit account2) - Test_tez.(info1.full_balance -! info1.frozen_deposits) + Tez_helpers.(info1.full_balance -! info1.frozen_deposits) in let* b2 = Block.bake ~policy:(Block.By_account account2) genesis ~operations:[op] @@ -786,7 +780,7 @@ let test_freeze_more_with_low_balance = in let {Q.num; den} = Percentage.to_q one_minus_slash_percentage in let expected_frozen_deposits_after = - Test_tez.(info2.frozen_deposits *! Z.to_int64 num /! Z.to_int64 den) + Tez_helpers.(info2.frozen_deposits *! Z.to_int64 num /! Z.to_int64 den) in let* () = Assert.equal_tez diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_baking.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_baking.ml index 48b16308e83444d572fdf706183ac62a3ba18068..45fb1656202faffe375449a4c95ca25faca7783e 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_baking.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_baking.ml @@ -127,7 +127,7 @@ let test_valid_double_baking_evidence () = let autostaked = Block.autostaked baker1 end_cycle_metadata in let Q.{num; den} = Percentage.to_q p in let expected_frozen_deposits_after = - Test_tez.( + Tez_helpers.( frozen_deposits_before -! (initial_frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) +! autostaked) @@ -210,7 +210,7 @@ let test_valid_double_baking_followed_by_double_attesting () = let p = Percentage.add_bounded p_de p_db in let Q.{num; den} = Percentage.to_q p in let expected_frozen_deposits_after = - Test_tez.( + Tez_helpers.( frozen_deposits_before -! (initial_frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) +! autostaked) @@ -291,7 +291,7 @@ let test_valid_double_attesting_followed_by_double_baking () = let p = Percentage.add_bounded p_de p_db in let Q.{num; den} = Percentage.to_q p in let expected_frozen_deposits_after = - Test_tez.( + Tez_helpers.( frozen_deposits_before -! (initial_frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) +! autostaked) @@ -370,7 +370,7 @@ let test_payload_producer_gets_evidence_rewards () = Context.Delegate.full_balance (B b') baker2 in let real_reward_right_after = - Test_tez.(full_balance_with_rewards_right_after -! full_balance) + Tez_helpers.(full_balance_with_rewards_right_after -! full_balance) in let* () = Assert.equal_tez @@ -391,7 +391,7 @@ let test_payload_producer_gets_evidence_rewards () = in let Q.{num; den} = Percentage.to_q p in let expected_frozen_deposits_after = - Test_tez.( + Tez_helpers.( frozen_deposits_before -! (initial_frozen_deposits_before *! Z.to_int64 num /! Z.to_int64 den) +! autostaked) @@ -404,7 +404,8 @@ let test_payload_producer_gets_evidence_rewards () = expected_frozen_deposits_after in let slashed_amount = - Test_tez.(frozen_deposits_before -! (frozen_deposits_after -! autostaked)) + Tez_helpers.( + frozen_deposits_before -! (frozen_deposits_after -! autostaked)) in (* [baker2] included the double baking evidence in [b_with_evidence] and so it receives the reward for the evidence included in [b'] @@ -415,18 +416,19 @@ let test_payload_producer_gets_evidence_rewards () = (Int64.of_int c.parametric.adaptive_issuance.global_limit_of_staking_over_baking) in - let evidence_reward = Test_tez.(slashed_amount /! divider) in + let evidence_reward = Tez_helpers.(slashed_amount /! divider) in let baked_blocks = Int64.of_int (Int32.to_int b'.header.shell.level - Int32.to_int b1.header.shell.level) in let expected_reward = - Test_tez.((baking_reward_fixed_portion *! baked_blocks) +! evidence_reward) + Tez_helpers.( + (baking_reward_fixed_portion *! baked_blocks) +! evidence_reward) in let* full_balance_with_rewards = Context.Delegate.full_balance (B b') baker2 in - let real_reward = Test_tez.(full_balance_with_rewards -! full_balance) in + let real_reward = Tez_helpers.(full_balance_with_rewards -! full_balance) in let* () = Assert.equal_tez ~loc:__LOC__ expected_reward real_reward in (* [baker1] did not produce the payload, it does not receive the reward for the evidence *) @@ -435,7 +437,7 @@ let test_payload_producer_gets_evidence_rewards () = Assert.equal_tez ~loc:__LOC__ full_balance_at_b' - Test_tez.(full_balance_at_b1 -! slashed_amount) + Tez_helpers.(full_balance_at_b1 -! slashed_amount) (****************************************************************) (* The following test scenarios are supposed to raise errors. *) diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_preattestation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_preattestation.ml index 1b1c73da09a0fbe179ce529cfc6e4beee8926a5d..75b1c947f717adb86aee6959ee2726f106aa643e 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_preattestation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_double_preattestation.ml @@ -152,11 +152,11 @@ end = struct let* bal_good = Context.Delegate.full_balance (B bgood) d1 in let* bal_bad = Context.Delegate.full_balance (B bbad) d1 in (* the diff of the two balances in normal and in denunciation cases *) - let diff_end_bal = Test_tez.(bal_good -! bal_bad) in + let diff_end_bal = Tez_helpers.(bal_good -! bal_bad) in (* amount lost due to denunciation *) let Q.{num; den} = Percentage.to_q p in let lost_deposit = - Test_tez.(frozen_deposit *! Z.to_int64 num /! Z.to_int64 den) + Tez_helpers.(frozen_deposit *! Z.to_int64 num /! Z.to_int64 den) in (* some of the lost deposits (depending on staking constants) will be earned by the baker *) let divider = @@ -166,11 +166,11 @@ end = struct constants.parametric.adaptive_issuance .global_limit_of_staking_over_baking) in - let denun_reward = Test_tez.(lost_deposit /! divider) in + let denun_reward = Tez_helpers.(lost_deposit /! divider) in (* if the baker is the attester, he'll only loose half of the deposits *) let expected_attester_loss = if Signature.Public_key_hash.equal baker d1 then - Test_tez.(lost_deposit -! denun_reward) + Tez_helpers.(lost_deposit -! denun_reward) else lost_deposit in let* () = @@ -188,7 +188,7 @@ end = struct if Signature.Public_key_hash.equal baker d1 then (bal_good, bal_bad) else (bal_bad, bal_good) in - let diff_baker = Test_tez.(high -! low) in + let diff_baker = Tez_helpers.(high -! low) in (* the baker has either earnt or lost (in case baker = d1) half of burnt attestation deposits *) let* () = Assert.equal_tez ~loc:__LOC__ denun_reward diff_baker in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_frozen_deposits.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_frozen_deposits.ml index 955ac2898a4be756c4bed491bf53966bdf7801af..5c576ea38f5905407ddd57c276d7d19d46472b68 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_frozen_deposits.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_frozen_deposits.ml @@ -33,7 +33,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers let constants = { @@ -87,7 +87,7 @@ let test_invariants () = Assert.equal_tez ~loc:__LOC__ full_balance - Test_tez.(spendable_balance +! frozen_deposits) + Tez_helpers.(spendable_balance +! frozen_deposits) in (* to see how delegation plays a role, let's delegate to account1; N.B. account2 represents a delegate so it cannot delegate to account1; this is @@ -126,16 +126,16 @@ let test_invariants () = Assert.equal_tez ~loc:__LOC__ new_staking_balance - Test_tez.(new_full_balance +! new_account_balance) + Tez_helpers.(new_full_balance +! new_account_balance) in let* () = Assert.equal_tez ~loc:__LOC__ new_full_balance - Test_tez.(new_spendable_balance +! new_frozen_deposits) + Tez_helpers.(new_spendable_balance +! new_frozen_deposits) in let expected_new_frozen_deposits = - Test_tez.( + Tez_helpers.( (* in this particular example, if we follow the calculation of the active stake, it is precisely the new_staking_balance *) new_staking_balance @@ -196,9 +196,9 @@ let test_limit_with_overdelegation () = let* initial_staking_balance' = Context.Delegate.staking_balance (B genesis) account2 in - let amount = Test_tez.(initial_staking_balance *! 8L /! 10L) in - let amount' = Test_tez.(initial_staking_balance' *! 8L /! 10L) in - let limit = Test_tez.(initial_staking_balance *! 15L /! 100L) in + let amount = Tez_helpers.(initial_staking_balance *! 8L /! 10L) in + let amount' = Tez_helpers.(initial_staking_balance' *! 8L /! 10L) in + let limit = Tez_helpers.(initial_staking_balance *! 15L /! 100L) in let new_account = (Account.new_account ()).pkh in let new_contract = Contract.Implicit new_account in let* transfer1 = @@ -209,7 +209,7 @@ let test_limit_with_overdelegation () = in let* b = Block.bake ~operations:[transfer1; transfer2] genesis in let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! amount) + Tez_helpers.(initial_staking_balance -! amount) in let* new_staking_balance = Context.Delegate.staking_balance (B b) account1 in let* () = @@ -219,7 +219,7 @@ let test_limit_with_overdelegation () = expected_new_staking_balance in let expected_new_staking_balance' = - Test_tez.(initial_staking_balance' -! amount') + Tez_helpers.(initial_staking_balance' -! amount') in let* new_staking_balance' = Context.Delegate.staking_balance (B b) account2 in let* () = @@ -401,7 +401,7 @@ let test_set_limit balance_percentage () = let* () = Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_deposits in (* set deposits limit to balance_percentage out of the balance *) let limit = - Test_tez.(full_balance *! Int64.of_int balance_percentage /! 100L) + Tez_helpers.(full_balance *! Int64.of_int balance_percentage /! 100L) in let* operation = Op.set_deposits_limit (B genesis) contract1 (Some limit) in let* b = Block.bake ~policy:(By_account account2) ~operation b in @@ -537,7 +537,7 @@ let test_deposits_after_stake_removal () = in (* Move half the account1's balance to account2 *) let* full_balance = Context.Delegate.full_balance (B genesis) account1 in - let half_balance = Test_tez.(full_balance /! 2L) in + let half_balance = Tez_helpers.(full_balance /! 2L) in let* operation = Op.transaction (B genesis) contract1 contract2 half_balance in @@ -556,7 +556,7 @@ let test_deposits_after_stake_removal () = in (* Bake a cycle. *) let expected_new_frozen_deposits_2 = - Test_tez.(initial_frozen_deposits_2 *! 3L /! 2L) + Tez_helpers.(initial_frozen_deposits_2 *! 3L /! 2L) in let* b = Block.bake_until_cycle_end b in let* frozen_deposits_2 = @@ -708,7 +708,7 @@ let test_frozen_deposits_with_delegation () = let* b = Block.bake ~operation:transfer genesis in let* new_staking_balance = Context.Delegate.staking_balance (B b) account2 in let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! delegated_amount) + Tez_helpers.(initial_staking_balance -! delegated_amount) in let* () = Assert.equal_tez @@ -721,7 +721,7 @@ let test_frozen_deposits_with_delegation () = in let* b = Block.bake ~operation:delegation b in let expected_new_staking_balance = - Test_tez.(initial_staking_balance +! delegated_amount) + Tez_helpers.(initial_staking_balance +! delegated_amount) in let* new_staking_balance = Context.Delegate.staking_balance (B b) account1 in let* () = @@ -733,7 +733,7 @@ let test_frozen_deposits_with_delegation () = (* Bake one cycle. *) let* b = Block.bake_until_cycle_end b in let expected_new_frozen_deposits = - Test_tez.( + Tez_helpers.( initial_frozen_deposits +! delegated_amount /! Int64.of_int (constants.limit_of_delegation_over_baking + 1)) @@ -799,7 +799,7 @@ let test_frozen_deposits_with_overdelegation () = in let* b = Block.bake ~operations:[transfer1; transfer2] genesis in let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! amount) + Tez_helpers.(initial_staking_balance -! amount) in let* new_staking_balance = Context.Delegate.staking_balance (B b) account1 in let* () = @@ -809,7 +809,7 @@ let test_frozen_deposits_with_overdelegation () = expected_new_staking_balance in let expected_new_staking_balance' = - Test_tez.(initial_staking_balance' -! amount') + Tez_helpers.(initial_staking_balance' -! amount') in let* new_staking_balance' = Context.Delegate.staking_balance (B b) account2 in let* () = @@ -824,7 +824,7 @@ let test_frozen_deposits_with_overdelegation () = let* b = Block.bake ~operation:delegation b in let* new_staking_balance = Context.Delegate.staking_balance (B b) account1 in let expected_new_staking_balance = - Test_tez.(initial_frozen_deposits +! amount +! amount') + Tez_helpers.(initial_frozen_deposits +! amount +! amount') in let* () = Assert.equal_tez @@ -895,9 +895,9 @@ let test_set_limit_with_overdelegation () = let* initial_staking_balance' = Context.Delegate.staking_balance (B genesis) account2 in - let amount = Test_tez.(initial_staking_balance *! 8L /! 10L) in - let amount' = Test_tez.(initial_staking_balance' *! 8L /! 10L) in - let limit = Test_tez.(initial_staking_balance *! 15L /! 100L) in + let amount = Tez_helpers.(initial_staking_balance *! 8L /! 10L) in + let amount' = Tez_helpers.(initial_staking_balance' *! 8L /! 10L) in + let limit = Tez_helpers.(initial_staking_balance *! 15L /! 100L) in let new_account = (Account.new_account ()).pkh in let new_contract = Contract.Implicit new_account in let* transfer1 = @@ -910,7 +910,7 @@ let test_set_limit_with_overdelegation () = let* set_deposits = Op.set_deposits_limit (B b) contract1 (Some limit) in let* b = Block.bake ~operation:set_deposits b in let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! amount) + Tez_helpers.(initial_staking_balance -! amount) in let* new_staking_balance = Context.Delegate.staking_balance (B b) account1 in let* () = @@ -920,7 +920,7 @@ let test_set_limit_with_overdelegation () = expected_new_staking_balance in let expected_new_staking_balance' = - Test_tez.(initial_staking_balance' -! amount') + Tez_helpers.(initial_staking_balance' -! amount') in let* new_staking_balance' = Context.Delegate.staking_balance (B b) account2 in let* () = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_participation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_participation.ml index ee03cdcc6d8af84865f6de511b5d6973498afaa5..a5e31c42c1f6e04743174e71d6c083ccffae4282 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_participation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_participation.ml @@ -142,7 +142,7 @@ let test_participation ~sufficient_participation () = del2 attesting_rewards in - let attesting_rewards = Test_tez.to_mutez attesting_rewards in + let attesting_rewards = Tez_helpers.to_mutez attesting_rewards in let expected_bal2_at_b = Int64.(sub (add bal2_at_pred_b attesting_rewards) autostaked) in @@ -175,7 +175,8 @@ let test_participation_rpc () = ~reward_kind:Attesting_reward_per_slot in let expected_attesting_rewards = - Test_tez.(attesting_reward_per_slot *! Int64.of_int expected_cycle_activity) + Tez_helpers.( + attesting_reward_per_slot *! Int64.of_int expected_cycle_activity) in let* b1 = Block.bake ~policy:(By_account del1) b0 in let* _, _, _ = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_seed.ml index 8409efd6e7b29ebbdaee390892e7e57acdea49ae..8bfd3ad5fd29804b4dfff4e2de8ed2f59cf9229f 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/consensus/test_seed.ml @@ -148,7 +148,6 @@ let test_revelation_early_wrong_right_twice () = (* test that the baking reward is received *) let* reward_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh @@ -214,7 +213,6 @@ let test_revelation_early_wrong_right_twice () = (* test that the baker gets the tip reward plus the baking reward*) let* tip_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh @@ -222,13 +220,14 @@ let test_revelation_early_wrong_right_twice () = in let* baking_reward_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh baking_reward_fixed_portion in - let reward_to_liquid = Test_tez.(baking_reward_to_liquid +! tip_to_liquid) in + let reward_to_liquid = + Tez_helpers.(baking_reward_to_liquid +! tip_to_liquid) + in let* () = balance_was_credited ~loc:__LOC__ (B b) baker baker_bal reward_to_liquid @@ -417,7 +416,6 @@ let test_early_incorrect_unverified_correct_already_vdf () = (* test that the baking reward is received *) let* reward_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh @@ -443,7 +441,6 @@ let test_early_incorrect_unverified_correct_already_vdf () = (* test that the baker gets the tip reward plus the baking reward*) let* tip_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh @@ -451,13 +448,14 @@ let test_early_incorrect_unverified_correct_already_vdf () = in let* baking_reward_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh baking_reward_fixed_portion in - let reward_to_liquid = Test_tez.(tip_to_liquid +! baking_reward_to_liquid) in + let reward_to_liquid = + Tez_helpers.(tip_to_liquid +! baking_reward_to_liquid) + in let* () = balance_was_credited ~loc:__LOC__ (B b) baker baker_bal reward_to_liquid in @@ -539,7 +537,6 @@ let test_early_incorrect_unverified_correct_already_vdf () = let* b = Block.bake ~policy:(Block.By_account baker_pkh) ~operation b in let* tip_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh @@ -547,14 +544,13 @@ let test_early_incorrect_unverified_correct_already_vdf () = in let* baking_reward_to_liquid = Adaptive_issuance_helpers.portion_of_rewards_to_liquid_for_cycle - ~policy (B b) cycle_for_rewards pkh baking_reward_fixed_portion in let reward_to_liquid = - Test_tez.(tip_to_liquid +! baking_reward_to_liquid) + Tez_helpers.(tip_to_liquid +! baking_reward_to_liquid) in let* () = balance_was_credited ~loc:__LOC__ (B b) baker baker_bal reward_to_liquid diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/dune b/src/proto_019_PtParisB/lib_protocol/test/integration/dune index 9b34e6bcb2531102e2a5443fe0c1beb940f45b64..afbf2c09b9002867e55ca6a8ba0e1d922854f861 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/dune +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/dune @@ -7,7 +7,6 @@ (libraries tezt.core tezt - octez-alcotezt octez-libs.base octez-protocol-019-PtParisB-libs.client tezos-protocol-019-PtParisB.protocol @@ -19,7 +18,6 @@ (:standard) -open Tezt_core -open Tezt_core.Base - -open Octez_alcotezt -open Tezos_base.TzPervasives -open Tezos_client_019_PtParisB -open Tezos_protocol_019_PtParisB @@ -30,7 +28,13 @@ test_constants test_frozen_bonds test_adaptive_issuance_launch - test_adaptive_issuance_roundtrip + test_scenario_base + test_scenario_stake + test_scenario_rewards + test_scenario_autostaking + test_scenario_slashing + test_scenario_slashing_stakers + test_scenario_deactivation test_liquidity_baking test_storage_functions test_storage diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/gas/test_gas_levels.ml index 85e4c6afa5e10cc9865e50c51b243975a3f159ae..53673770f75f5b1a84b724d3c81c62283e4a8471 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -558,7 +558,7 @@ let test_emptying_account_gas () = let bootstrap_pkh = Context.Contract.pkh bootstrap in let {Account.pkh; pk; _} = Account.new_account () in let contract = Contract.Implicit pkh in - let amount = Test_tez.of_int 10 in + let amount = Tez_helpers.of_int 10 in let* op1 = Op.transaction (B b) bootstrap contract amount in let* b = Block.bake ~operation:op1 b in let* op2 = Op.revelation ~fee:Tez.zero (B b) pk in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_contract_event.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_contract_event.ml index 180cfc760afa71075a415bab92b75cbb62e806d4..28729f9e1cf14132e396a961393b2139fc628d77 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_contract_event.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_contract_event.ml @@ -51,7 +51,7 @@ let originate_contract file storage src b = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in let* operation, dst = - Op.contract_origination (B b) src ~fee:(Test_tez.of_int 10) ~script + Op.contract_origination (B b) src ~fee:(Tez_helpers.of_int 10) ~script in let* incr = Incremental.begin_construction b in let* incr = Incremental.add_operation incr operation in @@ -65,10 +65,10 @@ let contract_test () = let open Lwt_result_syntax in let* b, src = Context.init1 ~consensus_threshold:0 () in let* dst, b = originate_contract (path // "contracts/emit.tz") "Unit" src b in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let parameters = Script.unit_parameter in let* operation = - Op.transaction ~fee ~parameters (B b) src dst (Test_tez.of_int 0) + Op.transaction ~fee ~parameters (B b) src dst (Tez_helpers.of_int 0) in let* incr = Incremental.begin_construction b in let* incr = Incremental.add_operation incr operation in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_sapling.ml index e8f7b0f833863186558f8027821003596d2ef717..a2248df9bf471ae50b4b7cc1b99c2682d230add2 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_sapling.ml @@ -33,7 +33,6 @@ open Protocol open Alpha_context -open Test_tez module Raw_context_tests = struct open Sapling_helpers.Common @@ -740,8 +739,8 @@ module Interpreter_tests = struct let* balance_after_shield = Context.Contract.balance (B b4) src1 in let diff_due_to_shield = Int64.sub - (Test_tez.to_mutez balance_after_shield) - (Test_tez.to_mutez balance_before_shield) + (Tez_helpers.to_mutez balance_after_shield) + (Tez_helpers.to_mutez balance_before_shield) in (* The balance after shield is obtained from the balance before shield by the shield specific update. *) @@ -791,7 +790,7 @@ module Interpreter_tests = struct in (* Here we fail by doing the same transaction again*) let* incr = Incremental.begin_construction b in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let dst = Alpha_context.Contract.Originated dst in let* operation = Op.transaction ~gas_limit:Max ~fee (B b) src0 dst Tez.zero ~parameters @@ -827,7 +826,7 @@ module Interpreter_tests = struct Alpha_context.Script.(lazy_expr (Expr.from_string string)) in let* incr = Incremental.begin_construction b in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let* operation = Op.transaction ~gas_limit:Max ~fee (B b) src0 dst Tez.zero ~parameters in @@ -996,8 +995,8 @@ module Interpreter_tests = struct ~offset_nullifier:0L () in - let fee = Test_tez.of_int 10 in - let*? amount_tez = Tez.one_mutez *? Int64.of_int 15 in + let fee = Tez_helpers.of_int 10 in + let*? amount_tez = Tez_helpers.(one_mutez *? Int64.of_int 15) in let* operation1 = Op.transaction ~gas_limit:High @@ -1113,7 +1112,7 @@ module Interpreter_tests = struct let* operation = Op.transaction ~gas_limit:Max - ~fee:(Test_tez.of_int 10) + ~fee:(Tez_helpers.of_int 10) (B b) src dst @@ -1159,7 +1158,7 @@ module Interpreter_tests = struct let parameters_2 = Alpha_context.Script.(lazy_expr (Expr.from_string str_2)) in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let cdst = Contract.Originated dst in let* operation = Op.transaction @@ -1252,7 +1251,7 @@ module Interpreter_tests = struct let parameters = Alpha_context.Script.(lazy_expr (Expr.from_string string)) in - let fee = Test_tez.of_int 10 in + let fee = Tez_helpers.of_int 10 in let dst = Contract.Originated dst in let* operation = Op.transaction ~gas_limit:Max ~fee (B b) src dst Tez.zero ~parameters diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 31834e5628cff29a164f8766ce8ea5b7cffc8177..21e947ee8419b0aeb4ada91e89ba1e649b65c98a 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -318,7 +318,7 @@ let originate_script block ~script ~storage ~sender ~baker ~forges_tickets = Op.contract_origination_hash (B block) sender - ~fee:(Test_tez.of_int 10) + ~fee:(Tez_helpers.of_int 10) ~script in let* incr = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index eaaa40714419fc1eb1539d8a72621408dd897283..95a4bab76c449e7375f6648ddf98409a0d0d0a48 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -220,7 +220,7 @@ let originate block ~script ~storage ~sender ~baker ~forges_tickets = Op.contract_origination_hash (B block) sender - ~fee:(Test_tez.of_int 10) + ~fee:(Tez_helpers.of_int 10) ~script in let* incr = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_activation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_activation.ml index ea9c6077d676ee49b2c883d5c99eb9ba376f25e0..b4c2680b423643c453aa82ed154b0eead6cbad89 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_activation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_activation.ml @@ -43,7 +43,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers (* Generated commitments and secrets *) @@ -426,7 +426,7 @@ let test_activation_and_transfer () = let* operation = Op.activation (B blk) account activation_code in let* blk = Block.bake ~operation blk in let* amount = Context.Contract.balance (B blk) bootstrap_contract in - let half_amount = Test_tez.(amount /! 2L) in + let half_amount = Tez_helpers.(amount /! 2L) in let* activated_amount_before = Context.Contract.balance (B blk) first_contract in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_combined_operations.ml index 4a888cdc3a67b773de31cd09a576bd9802ba42da..aabab315dddb0e1474c5b070bb4f8d0a3042cbde 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -31,21 +31,28 @@ Subject: Multiple operations can be grouped in one ensuring their deterministic application. - If an invalid operation is present in this group of - operations, the previously applied operations are - backtracked leaving the context unchanged and the - following operations are skipped. Fees attributed to the - operations are collected by the baker nonetheless. + Only manager operations are allowed in batches of more + than one operation. This file only tests batches where + all operations belong to the same manager. See + {!Test_host_operation} for tests involving multiple + managers. - Only manager operations are allowed in multiple transactions. - They must all belong to the same manager as there is only one - signature. + For single-manager batches, if an invalid operation is + present in this group of operations then the + previously applied operations are backtracked, leaving + the context unchanged, and the following operations + are skipped. Fees attributed to the operations are + collected by the baker nonetheless. + + There may be overlap with + [lib_protocol/test/integration/validate/test_validation_batch.ml]. *) open Protocol open Alpha_context +open Error_helpers -let ten_tez = Test_tez.of_int 10 +let ten_tez = Tez_helpers.of_int 10 let gas_limit = Op.Custom_gas (Alpha_context.Gas.Arith.integral_of_int_exn 3000) @@ -72,7 +79,7 @@ let test_multiple_transfers () = (I inc) c1 c1_old_balance - (Test_tez.of_int 10) + (Tez_helpers.of_int 10) in let* () = Assert.balance_was_credited @@ -80,7 +87,7 @@ let test_multiple_transfers () = (I inc) c2 c2_old_balance - (Test_tez.of_int 10) + (Tez_helpers.of_int 10) in return_unit @@ -103,7 +110,7 @@ let test_multiple_origination_and_delegation () = ~counter:(Manager_counter.Internal_for_tests.of_int i) ~fee:Tez.zero ~script:Op.dummy_script - ~credit:(Test_tez.of_int 10) + ~credit:(Tez_helpers.of_int 10) (B blk) c1) (1 -- n) @@ -148,21 +155,21 @@ let test_multiple_origination_and_delegation () = in (* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *) let*? origination_burn = - Test_tez.(cost_per_byte *? Int64.of_int origination_size) + Tez_helpers.(cost_per_byte *? Int64.of_int origination_size) in let*? origination_total_cost = - Test_tez.(origination_burn *? Int64.of_int n) + Tez_helpers.(origination_burn *? Int64.of_int n) in - let*? t = Test_tez.( *? ) Op.dummy_script_cost 10L in - let*? t = Test_tez.( +? ) (Test_tez.of_int (10 * n)) t in - let*? total_cost = Test_tez.( +? ) origination_total_cost t in + let*? t = Tez_helpers.( *? ) Op.dummy_script_cost 10L in + let*? t = Tez_helpers.( +? ) (Tez_helpers.of_int (10 * n)) t in + let*? total_cost = Tez_helpers.( +? ) origination_total_cost t in let* () = Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost in List.iter_es (fun c -> let c = Contract.Originated c in - Assert.balance_is ~loc:__LOC__ (I inc) c (Test_tez.of_int 10)) + Assert.balance_is ~loc:__LOC__ (I inc) c (Tez_helpers.of_int 10)) new_contracts let expect_apply_failure = @@ -185,7 +192,7 @@ let test_failing_operation_in_the_middle () = let* blk, (c1, c2) = Context.init2 () in let* op1 = Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one in let* op2 = - Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Test_tez.max_tez + Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez_helpers.max_tez in let* op3 = Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one in let operations = [op1; op2; op3] in @@ -232,7 +239,7 @@ let test_failing_operation_in_the_middle_with_fees () = let open Lwt_result_syntax in let* blk, (c1, c2) = Context.init2 () in let* op1 = Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one in - let* op2 = Op.transaction ~fee:Tez.one (B blk) c1 c2 Test_tez.max_tez in + let* op2 = Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez_helpers.max_tez in let* op3 = Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one in let operations = [op1; op2; op3] in let* operation = Op.combine_operations ~source:c1 (B blk) operations in @@ -274,7 +281,7 @@ let test_failing_operation_in_the_middle_with_fees () = (I inc) c1 c1_old_balance - (Test_tez.of_int 3) + (Tez_helpers.of_int 3) in let* () = Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance in return_unit @@ -301,45 +308,18 @@ let test_wrong_signature_in_the_middle () = Op.transaction ~gas_limit ~fee:Tez.one (B b) c2 c1 Tez.one in let operations = [op1; op2; op3] in - let* operation = Op.combine_operations ~spurious_operation ~source:c1 (B b) operations in - let expect_failure = function - | Environment.Ecoproto_error - (Validate_errors.Manager.Inconsistent_sources as err) - :: _ -> - Assert.test_error_encodings err ; - return_unit - | _ -> - failwith - "Packed operation has invalid source in the middle : operation \ - expected to fail." - in let* inc = Incremental.begin_construction b in - let* (_inc : Incremental.t) = + let* (_ : Incremental.t) = + let expect_failure = + expect_inconsistent_sources ~loc:__LOC__ ~first_source:c1 ~source:c2 + in Incremental.add_operation ~expect_failure inc operation in return_unit -let expect_inconsistent_counters list = - let open Lwt_result_syntax in - if - List.exists - (function - | Environment.Ecoproto_error - Validate_errors.Manager.Inconsistent_counters -> - true - | _ -> false) - list - then return_unit - else - failwith - "Packed operation has inconsistent counters : operation expected to fail \ - but got errors: %a." - Error_monad.pp_print_trace - list - let test_inconsistent_counters () = let open Lwt_result_syntax in let* blk, (c1, c2) = Context.init2 () in @@ -405,18 +385,26 @@ let test_inconsistent_counters () = (* Gap in counter in the following op *) let* op = Op.batch_operations ~source:c1 (B b) [op1; op2; op4] in let* (_ : Incremental.t) = - Incremental.add_operation - ~expect_failure:expect_inconsistent_counters - inc - op + let expect_failure = + expect_inconsistent_counters_int + ~loc:__LOC__ + ~source:c1 + ~previous_counter:3 + ~counter:5 + in + Incremental.add_operation ~expect_failure inc op in (* Same counter used twice in the following op *) let* op = Op.batch_operations ~source:c1 (B b) [op1; op2; op2'] in let* (_ : Incremental.t) = - Incremental.add_operation - ~expect_failure:expect_inconsistent_counters - inc - op + let expect_failure = + expect_inconsistent_counters_int + ~loc:__LOC__ + ~source:c1 + ~previous_counter:3 + ~counter:3 + in + Incremental.add_operation ~expect_failure inc op in return_unit diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_origination.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_origination.ml index 309378cfe2395ad0e4a4c18a19ca9a06d566b527..393701082a38ae4bc982b06107e635867b65db33 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_origination.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_origination.ml @@ -33,7 +33,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers let ten_tez = of_int 10 diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_paid_storage_increase.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_paid_storage_increase.ml index 5bba4569f76f80d0c363b6353e64734a28c8006f..ef243b832685fa3b1bc7a5d9945fc4ad1ca93301 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_paid_storage_increase.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_paid_storage_increase.ml @@ -34,7 +34,7 @@ open Protocol open Alpha_context -let ten_tez = Test_tez.of_int 10 +let ten_tez = Tez_helpers.of_int 10 let dummy_script = "{parameter unit; storage unit; code { CAR ; NIL operation ; PAIR }}" @@ -80,7 +80,7 @@ let test_balances ~amount = (* check that after the block has been baked, the source was debited of all the burned tez *) let* {parametric = {cost_per_byte; _}; _} = Context.get_constants (I inc) in - let burned_tez = Test_tez.(cost_per_byte *! Z.to_int64 amount) in + let burned_tez = Tez_helpers.(cost_per_byte *! Z.to_int64 amount) in let* () = Assert.balance_was_debited ~loc:__LOC__ @@ -144,7 +144,7 @@ let test_no_tez_to_pay () = Z.div (Z.of_int 2_000_000) (Z.of_int64 (Tez.to_mutez cost_per_byte)) in let* balance = Context.Contract.balance (I inc) source in - let*? tez_to_substract = Test_tez.(balance -? Tez.one) in + let*? tez_to_substract = Tez_helpers.(balance -? Tez.one) in let* op = Op.transaction (I inc) ~fee:Tez.zero source receiver tez_to_substract in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_reveal.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_reveal.ml index d703c7ee1478c0d4f81059e449bc03438d1cdefc..ffd96c441d8ea49e8b8355460e22edf885ee30c3 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_reveal.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_reveal.ml @@ -35,7 +35,8 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers +open Error_helpers let ten_tez = of_int 10 @@ -573,14 +574,7 @@ let test_reveal_incorrect_position_in_batch () = (I inc) [op_transfer; op_reveal] in - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in let* inc = Incremental.add_operation ~expect_failure inc batched_operation in (* We assert the manager key is still unrevealed, as the operation has failed *) let* revelead = @@ -617,14 +611,7 @@ let test_duplicate_valid_reveals () = (I inc) [op_rev1; op_rev2] in - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in let* inc = Incremental.add_operation ~expect_failure inc batched_operation in (* We assert the manager key is still unrevealed, as the operation has failed *) let* revelead = @@ -666,14 +653,7 @@ let test_valid_reveal_after_gas_exhausted_one () = (I inc) [bad_reveal; good_reveal] in - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in let* inc = Incremental.add_operation ~expect_failure inc batched_operation in (* We assert the manager key is still unrevealed, as the batch has failed *) let+ revealed = @@ -717,14 +697,7 @@ let test_valid_reveal_after_insolvent_one () = (I inc) [bad_reveal; good_reveal; transfer] in - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in let* inc = Incremental.add_operation ~expect_failure inc batched_operation in (* We assert the manager key is still unrevealed, as the batch has failed *) let+ revealed = @@ -764,14 +737,7 @@ let test_valid_reveal_after_emptying_balance () = (I inc) [bad_reveal; good_reveal] in - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in let* inc = Incremental.add_operation ~expect_failure inc batched_operation in (* We assert the manager key is still unrevealed, as the batch has failed *) let+ revealed = diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_sc_rollup.ml index ee5c02c3b0f8794e714ad4373414d09f00b57a54..257af9b272861e28694b75aec88a77851efda675 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -164,8 +164,8 @@ let bake_timeout_period ?timeout_period_in_blocks block = context and contracts. *) let context_init ?commitment_period_in_blocks ?(sc_rollup_challenge_window_in_blocks = 10) - ?(timeout_period_in_blocks = 10) ?hard_gas_limit_per_operation - ?hard_gas_limit_per_block tup = + ?sc_rollup_max_active_outbox_levels ?(timeout_period_in_blocks = 10) + ?hard_gas_limit_per_operation ?hard_gas_limit_per_block tup = Context.init_with_constants_gen tup { @@ -185,6 +185,12 @@ let context_init ?commitment_period_in_blocks arith_pvm_enable = true; private_enable = true; challenge_window_in_blocks = sc_rollup_challenge_window_in_blocks; + max_active_outbox_levels = + Option.value + ~default: + Context.default_test_constants.sc_rollup + .max_active_outbox_levels + sc_rollup_max_active_outbox_levels; commitment_period_in_blocks = Option.value ~default: @@ -979,7 +985,6 @@ let test_originating_with_invalid_types () = [ "mutez"; "big_map string nat"; - "contract string"; "sapling_state 2"; "sapling_transaction 2"; "lambda string nat"; @@ -1581,7 +1586,14 @@ let test_invalid_output_proof () = let test_execute_message_override_applied_messages_slot () = let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in + (* Since we will create more blocks than the [max_active_outbox_levels] + parametric constant, we initialize it with a small enough value. *) + let* block, (baker, originator) = + context_init + ~sc_rollup_max_active_outbox_levels:100l + ~commitment_period_in_blocks:50 + Context.T2 + in let baker = Context.Contract.pkh baker in (* Originate a rollup that accepts a list of string tickets as input. *) let* block, rollup = @@ -1851,6 +1863,7 @@ let test_number_of_parallel_games_bounded () = let* block, accounts = context_init ~sc_rollup_challenge_window_in_blocks:100 + ~hard_gas_limit_per_block:(Gas.Arith.integral_of_int_exn 1_000_000_000) (Context.TList nb_accounts) in let* block, rollup = sc_originate block (Stdlib.List.hd accounts) in @@ -2903,7 +2916,7 @@ let test_curfew () = let open Lwt_result_syntax in let* block, (account1, account2, account3), rollup = (* sc_rollup_challenge_window_in_blocks should be at least commitment period *) - init_and_originate ~sc_rollup_challenge_window_in_blocks:90 Context.T3 + init_and_originate ~sc_rollup_challenge_window_in_blocks:112 Context.T3 in let* constants = Context.get_constants (B block) in let challenge_window = @@ -3309,7 +3322,7 @@ let test_conflict_point_on_a_branch () = let test_agreeing_stakers_cannot_play () = let open Lwt_result_syntax in let* block, (pA, pB), rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks:1000 Context.T2 + init_and_originate ~sc_rollup_challenge_window_in_blocks:1009 Context.T2 in let pB_pkh = Account.pkh_of_contract_exn pB in (* pA stakes on a whole branch. *) @@ -3341,7 +3354,7 @@ let test_agreeing_stakers_cannot_play () = let test_start_game_on_cemented_commitment () = let open Lwt_result_syntax in let* block, (pA, pB), rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks:1000 Context.T2 + init_and_originate ~sc_rollup_challenge_window_in_blocks:1009 Context.T2 in let* constants = Context.get_constants (B block) in let pA_pkh = Account.pkh_of_contract_exn pA in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_transfer.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_transfer.ml index 50b9189de72b77ffffe6c8525f0e6f6a67855bfe..3dd1b929a1d0daeea9f937255cc6fb471f2c7e43 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_transfer.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_transfer.ml @@ -33,7 +33,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers open Transfers (*********************************************************************) diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_voting.ml index 24ad8eaae0ef7e10018ffee88a55aee238481af2..435aab0314a67f51223c40cb2bb6be5194f75bee 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_voting.ml @@ -970,11 +970,11 @@ let test_supermajority_in_proposal there_is_a_winner () = minimal_stake in let*? bal3 = - if there_is_a_winner then Test_tez.( *? ) minimal_stake 3L + if there_is_a_winner then Tez_helpers.( *? ) minimal_stake 3L else let open Result_syntax in - let* t = Test_tez.( *? ) minimal_stake 2L in - Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance) t + let* t = Tez_helpers.( *? ) minimal_stake 2L in + Tez_helpers.( +? ) (Tez_helpers.of_mutez initial_balance) t in let* op3 = Op.transaction @@ -1039,7 +1039,7 @@ let test_quorum_in_proposal has_quorum () = else Int64.(sub (of_int32 min_proposal_quorum) 10L) in let bal = - Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.of_mutez_exn + Int64.(div (mul total_tokens quorum) 100_00L) |> Tez_helpers.of_mutez in let* op2 = Op.transaction (B b) del2 del1 bal in let* b = Block.bake ~policy ~operation:op2 b in @@ -1251,33 +1251,27 @@ let test_voting_power_updated_each_voting_period () = let baker2 = Context.Contract.pkh con2 in let baker3 = Context.Contract.pkh con3 in (* Retrieve balance of con1 *) - let open Test_tez in + let open Tez_helpers in let* balance1 = Context.Contract.balance (B genesis) con1 in let* frozen_deposits1 = Context.Delegate.current_frozen_deposits (B genesis) baker1 in let*? full_balance1 = balance1 +? frozen_deposits1 in - let* () = - Assert.equal_tez ~loc:__LOC__ full_balance1 (of_mutez_exn init_bal1) - in + let* () = Assert.equal_tez ~loc:__LOC__ full_balance1 (of_mutez init_bal1) in (* Retrieve balance of con2 *) let* balance2 = Context.Contract.balance (B genesis) con2 in let* frozen_deposits2 = Context.Delegate.current_frozen_deposits (B genesis) baker2 in let*? full_balance2 = balance2 +? frozen_deposits2 in - let* () = - Assert.equal_tez ~loc:__LOC__ full_balance2 (of_mutez_exn init_bal2) - in + let* () = Assert.equal_tez ~loc:__LOC__ full_balance2 (of_mutez init_bal2) in (* Retrieve balance of con3 *) let* balance3 = Context.Contract.balance (B genesis) con3 in let* frozen_deposits3 = Context.Delegate.current_frozen_deposits (B genesis) baker3 in let*? full_balance3 = balance3 +? frozen_deposits3 in - let* () = - Assert.equal_tez ~loc:__LOC__ full_balance3 (of_mutez_exn init_bal3) - in + let* () = Assert.equal_tez ~loc:__LOC__ full_balance3 (of_mutez init_bal3) in (* Auxiliary assert_voting_power *) let assert_voting_power ~loc n block baker = let* voting_power = get_voting_power block baker in @@ -1317,7 +1311,7 @@ let test_voting_power_updated_each_voting_period () = (* Retrieve balance of con1 *) let* balance1 = Context.Contract.balance (B block) con1 in (* Assert balance has changed by deducing the amount *) - let*? balance1_after_deducing_amount = of_mutez_exn init_bal1 -? amount in + let*? balance1_after_deducing_amount = of_mutez init_bal1 -? amount in let* frozen_deposit1 = Context.Delegate.current_frozen_deposits (B block) baker1 in @@ -1328,7 +1322,7 @@ let test_voting_power_updated_each_voting_period () = (* Retrieve balance of con2 *) let* balance2 = Context.Contract.balance (B block) con2 in (* Assert balance has changed by adding amount *) - let*? balance2_after_adding_amount = of_mutez_exn init_bal2 +? amount in + let*? balance2_after_adding_amount = of_mutez init_bal2 +? amount in let* frozen_deposit2 = Context.Delegate.current_frozen_deposits (B block) baker2 in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_zk_rollup.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_zk_rollup.ml index 90a75b2d580ab9cd65c09cc9b97c48ad16a619e3..2ed43aa0b2094a8ae3673bf7f8f06fac3dee5d50 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_zk_rollup.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/operations/test_zk_rollup.ml @@ -149,7 +149,8 @@ let test_origination_fees () = + Data_encoding.Binary.length Zk_rollup.pending_list_encoding init_pl in let expected_fees = - Test_tez.(constants.parametric.cost_per_byte *! Int64.of_int expected_size) + Tez_helpers.( + constants.parametric.cost_per_byte *! Int64.of_int expected_size) in let* operation, _rollup = Op.zk_rollup_origination diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_launch.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_launch.ml index dd3e4a6d989515832e07da0e3d783f67c65de233..5a8e715fbb05ee96cbe02d6bd93940f13f5b3bb0 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_launch.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_launch.ml @@ -32,6 +32,10 @@ *) open Adaptive_issuance_helpers +module Cycle = Protocol.Alpha_context.Cycle + +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["ai"; "ai_launch"] let assert_level ~loc (blk : Block.t) expected = let current_level = blk.header.shell.level in @@ -109,7 +113,7 @@ let assert_voting_power ~loc block delegate ~ai_enabled ~expected_staked - the launch cycle is not reset before it is reached, - once the launch cycle is reached, staking is allowed, - staking increases total_frozen_stake. *) -let test_launch threshold expected_vote_duration () = +let test_launch threshold expected_vote_duration = let open Lwt_result_wrap_syntax in let assert_ema_above_threshold ~loc (metadata : Protocol.Main.block_header_metadata) = @@ -123,24 +127,6 @@ let test_launch threshold expected_vote_duration () = (* Initialize the state with a single delegate. *) let constants = let default_constants = Default_parameters.constants_test in - let default_constants = - { - default_constants with - dal = - { - default_constants.dal with - cryptobox_parameters = - { - default_constants.dal.cryptobox_parameters with - (* Computing the DAL committee takes a bit of time, around 1ms - for [number_of_shards] = 2048, and this adds up when baking - for a long time. As this issue is orthogonal to this test, we - simply pick a lower value. *) - number_of_shards = 32; - }; - }; - } - in let adaptive_issuance = { default_constants.adaptive_issuance with @@ -149,11 +135,11 @@ let test_launch threshold expected_vote_duration () = autostaking_enable = false; } in - let cost_per_byte = Tez.zero in + let cost_per_byte = Tez_helpers.zero in let issuance_weights = { Default_parameters.constants_test.issuance_weights with - base_total_issued_per_minute = Tez.zero; + base_total_issued_per_minute = Tez_helpers.zero; } in let consensus_threshold = 0 in @@ -406,7 +392,7 @@ let test_launch threshold expected_vote_duration () = - the EMA of the adaptive issuance vote reaches the threshold after the expected duration, - the feature does not activate. *) -let test_does_not_launch_without_feature_flag threshold vote_duration () = +let test_does_not_launch_without_feature_flag threshold vote_duration = let open Lwt_result_wrap_syntax in let assert_ema_above_threshold ~loc (metadata : Protocol.Main.block_header_metadata) = @@ -420,21 +406,6 @@ let test_does_not_launch_without_feature_flag threshold vote_duration () = (* Initialize the state with a single delegate. *) let constants = let default_constants = Default_parameters.constants_test in - let default_constants = - { - default_constants with - dal = - { - default_constants.dal with - cryptobox_parameters = - { - default_constants.dal.cryptobox_parameters with - (* same reasoning as for [test_launch] *) - number_of_shards = 32; - }; - }; - } - in let adaptive_issuance = { default_constants.adaptive_issuance with @@ -503,7 +474,7 @@ let test_launch_without_vote () = let issuance_weights = { Default_parameters.constants_test.issuance_weights with - base_total_issued_per_minute = Tez.zero; + base_total_issued_per_minute = Tez_helpers.zero; } in let adaptive_issuance = @@ -577,28 +548,23 @@ let test_launch_without_vote () = in return_unit -let tests = - [ - Tztest.tztest +let () = + register_test + ~title: "Launch with force_activation feature flag set activates AI immediately" - `Quick - test_launch_without_vote; - Tztest.tztest - "the EMA reaches the vote threshold at the expected level and adaptive \ - issuance launches (very low threshold, vote enabled)" - `Quick - (test_launch - 1000000l (* This means that the threshold is set at 0.05% *) - 88l); - Tztest.tztest - "the EMA reaches the vote threshold at the expected level and adaptive \ - issuance does not launch (very low threshold, vote disabled)" - `Quick - (test_does_not_launch_without_feature_flag - 1000000l (* This means that the threshold is set at 0.05% *) - 88l); - ] + test_launch_without_vote + +let () = + register_test + ~title:"expected EMA and AI launches (very low threshold, vote enabled)" + @@ fun () -> + test_launch 1000000l (* This means that the threshold is set to 0.05% *) 88l let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("adaptive issuance launch", tests)] - |> Lwt_main.run + register_test + ~title: + "expected EMA and AI does not launch (very low threshold, vote disabled)" + @@ fun () -> + test_does_not_launch_without_feature_flag + 1000000l (* This means that the threshold is set to 0.05% *) + 88l diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_roundtrip.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_roundtrip.ml deleted file mode 100644 index 49eefd7e4e3b6deaa596655d134be5251424d9cc..0000000000000000000000000000000000000000 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_roundtrip.ml +++ /dev/null @@ -1,2952 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Adaptive Issuance, launch vote - Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ - -- --file test_adaptive_issuance_roundtrip.ml - Subject: Test staking stability under Adaptive Issuance. -*) - -open Adaptive_issuance_helpers - -let fs = Format.asprintf - -(** Returns when the number of bootstrap accounts created by [Context.init_n n] is not equal to [n] *) -type error += Inconsistent_number_of_bootstrap_accounts - -(** For [assert_failure], when expected error does not match the actual error. *) -type error += Unexpected_error - -let default_param_wait, default_unstake_wait = - let constants = Default_parameters.constants_test in - let crd = constants.consensus_rights_delay in - let dpad = constants.delegate_parameters_activation_delay in - let msp = Protocol.Constants_repr.max_slashing_period in - (dpad, crd + msp) - -(** Contains the functions and constants relative to logging.*) -module Log_module = struct - let begin_end_color = Log.Color.(BG.bright_white ++ FG.black ++ bold) - - let time_color = Log.Color.FG.yellow - - let action_color = Log.Color.FG.green - - let event_color = Log.Color.FG.blue - - let warning_color = Log.Color.FG.red - - let low_debug_color = Log.Color.FG.gray - - let assert_block_color = Log.Color.(BG.blue ++ FG.gray) - - let tez_color = Log.Color.FG.bright_white - - let log_debug_balance account_name account_map : unit = - let balance, total_balance = - balance_and_total_balance_of_account account_name account_map - in - Log.debug - "Model balance of %s:\n%aTotal balance: %a\n" - account_name - balance_pp - balance - Tez.pp - total_balance - - let log_debug_rpc_balance name contract block : unit tzresult Lwt.t = - let open Lwt_result_syntax in - let* balance, total_balance = get_balance_from_context (B block) contract in - Log.debug - "RPC balance of %s:\n%aTotal balance: %a\n" - name - balance_pp - balance - Tez.pp - total_balance ; - return_unit - - let log_debug_balance_update account_name old_account_map new_account_map : - unit = - let old_balance, old_total_balance = - balance_and_total_balance_of_account account_name old_account_map - in - let new_balance, new_total_balance = - balance_and_total_balance_of_account account_name new_account_map - in - Log.debug - "Balance update of %s:\n%aTotal balance: %a -> %a\n" - account_name - balance_update_pp - (old_balance, new_balance) - Tez.pp - old_total_balance - Tez.pp - new_total_balance - - (* end module Log_module *) -end - -open Log_module - -(** Aliases for tez values *) -type tez_quantity = - | Half - | All - | All_but_one - | Nothing - | Max_tez - | Amount of Tez.t - -let tez_quantity_pp fmt value = - let s = - match value with - | Nothing -> "Zero" - | All -> "All" - | All_but_one -> "All but 1µꜩ" - | Half -> "Half" - | Max_tez -> "Maximum" - | Amount a -> Format.asprintf "%aꜩ" Tez.pp a - in - Format.fprintf fmt "%s" s - -(* [all] is the amount returned when [qty = All]. If [qty = Half], returns half of that. *) -let quantity_to_tez all qty = - match qty with - | Nothing -> Tez.zero - | All -> all - | All_but_one -> - if Tez.(equal all zero) then Tez.zero else Tez.(all -! one_mutez) - | Half -> Test_tez.(all /! 2L) - | Max_tez -> Tez.max_mutez - | Amount a -> a - -let default_params = - let Protocol.Staking_parameters_repr. - { - limit_of_staking_over_baking_millionth; - edge_of_baking_over_staking_billionth; - } = - Protocol.Staking_parameters_repr.default - in - { - limit_of_staking_over_baking = - Q.(Int32.to_int limit_of_staking_over_baking_millionth // 1_000_000); - edge_of_baking_over_staking = - Q.(Int32.to_int edge_of_baking_over_staking_billionth // 1_000_000_000); - } - -type double_signing_state = { - culprit : Signature.Public_key_hash.t; - kind : Protocol.Misbehaviour_repr.kind; - evidence : Context.t -> Protocol.Alpha_context.packed_operation; - denounced : bool; - level : Int32.t; -} - -(** Module for the [State.t] type of asserted information about the system during a test. *) -module State = struct - (** Type of the state *) - type t = { - account_map : account_map; - total_supply : Tez.t; - constants : Protocol.Alpha_context.Constants.Parametric.t; - param_requests : (string * staking_parameters * int) list; - activate_ai : bool; - baking_policy : Block.baker_policy option; - last_level_rewards : Protocol.Alpha_context.Raw_level.t; - snapshot_balances : (string * balance) list String.Map.t; - saved_rate : Q.t option; - burn_rewards : bool; - pending_operations : Protocol.Alpha_context.packed_operation list; - pending_slashes : - (Signature.Public_key_hash.t * Protocol.Denunciations_repr.item) list; - double_signings : double_signing_state list; - } - - (** Expected number of cycles before staking parameters get applied *) - let param_wait state = - state.constants.delegate_parameters_activation_delay + 1 - - (** Expected number of cycles before staking unstaked funds get unfrozen *) - let unstake_wait state = - let pc = state.constants.consensus_rights_delay in - let msp = Protocol.Constants_repr.max_slashing_period in - pc + msp - - (** From a name, returns the corresponding account *) - let find_account (account_name : string) (state : t) : account_state = - match String.Map.find account_name state.account_map with - | None -> raise Not_found - | Some r -> r - - let find_account_from_pkh (pkh : Signature.public_key_hash) (state : t) : - string * account_state = - String.Map.filter - (fun _ acc -> Signature.Public_key_hash.equal pkh acc.pkh) - state.account_map - |> String.Map.choose - |> function - | None -> raise Not_found - | Some (name, acc) -> (name, acc) - - let liquid_delegated ~name state = - let open Result_syntax in - String.Map.fold_e - (fun _delegator account acc -> - match account.delegate with - | Some delegate when not @@ String.equal delegate name -> return acc - | None -> return acc - | _ -> Tez.(acc +? account.liquid)) - state.account_map - Tez.zero - - (** Returns true iff account is a delegate *) - let is_self_delegate (account_name : string) (state : t) : bool = - let acc = find_account account_name state in - match acc.delegate with - | None -> false - | Some del_name -> String.equal del_name account_name - - let update_map ?(log_updates = []) ~(f : account_map -> account_map) - (state : t) : t = - let log_updates = List.sort_uniq String.compare log_updates in - let new_state = {state with account_map = f state.account_map} in - List.iter - (fun x -> - log_debug_balance_update x state.account_map new_state.account_map) - log_updates ; - new_state - - let apply_burn amount src_name (state : t) : t = - let f = apply_burn amount src_name in - let state = update_map ~log_updates:[src_name] ~f state in - {state with total_supply = Tez.(state.total_supply -! amount)} - - let apply_transfer amount src_name dst_name (state : t) : t = - let f = apply_transfer amount src_name dst_name in - update_map ~log_updates:[src_name; dst_name] ~f state - - let apply_stake amount current_cycle staker_name (state : t) : t = - let f = - apply_stake - amount - current_cycle - state.constants.consensus_rights_delay - staker_name - in - update_map ~log_updates:[staker_name] ~f state - - let apply_unstake cycle amount staker_name (state : t) : t = - let f = apply_unstake cycle amount staker_name in - update_map ~log_updates:[staker_name] ~f state - - let apply_finalize staker_name (state : t) : t = - let f = apply_finalize staker_name in - update_map ~log_updates:[staker_name] ~f state - - let apply_unslashable current_cycle account_name (state : t) : t = - let unstake_wait = unstake_wait state in - match Cycle.sub current_cycle unstake_wait with - | None -> state - | Some cycle -> - let f = apply_unslashable cycle account_name in - update_map ~log_updates:[account_name] ~f state - - let apply_unslashable_for_all current_cycle (state : t) : t = - let unstake_wait = unstake_wait state in - match Cycle.sub current_cycle unstake_wait with - | None -> state - | Some cycle -> - let f = apply_unslashable_for_all cycle in - (* no log *) - update_map ~f state - - let apply_rewards ~(baker : string) block (state : t) : t tzresult Lwt.t = - let open Lwt_result_syntax in - let {last_level_rewards; total_supply; constants = _; _} = state in - let*? current_level = Context.get_level (B block) in - let current_cycle = Block.current_cycle block in - (* We assume one block per minute *) - let* rewards_per_block = Context.get_issuance_per_minute (B block) in - if Tez.(rewards_per_block = zero) then return state - else - let delta_time = - Protocol.Alpha_context.Raw_level.diff current_level last_level_rewards - |> Int64.of_int32 - in - let {parameters = _; pkh; _} = find_account baker state in - let delta_rewards = Test_tez.(rewards_per_block *! delta_time) in - if delta_time = 1L then - Log.info ~color:tez_color "+%aꜩ" Tez.pp rewards_per_block - else assert false ; - let* to_liquid = - portion_of_rewards_to_liquid_for_cycle - ?policy:state.baking_policy - (B block) - current_cycle - pkh - delta_rewards - in - let to_frozen = Tez.(delta_rewards -! to_liquid) in - let state = update_map ~f:(add_liquid_rewards to_liquid baker) state in - let state = update_map ~f:(add_frozen_rewards to_frozen baker) state in - let* total_supply = Tez.(total_supply + delta_rewards) in - return {state with last_level_rewards = current_level; total_supply} - - (** [apply_staking_abstract_balance_updates] updates a state based on balance - updates (found in block application metadata). - It first collect all changes on pseudotokens, then apply them on - accounts. *) - let apply_staking_abstract_balance_updates balance_updates state = - let update_staking_delegator_numerator delta account_state = - let staking_delegator_numerator = - Z.add delta account_state.staking_delegator_numerator - in - {account_state with staking_delegator_numerator} - in - let update_staking_delegate_denominator delta account_state = - let staking_delegate_denominator = - Z.add delta account_state.staking_delegate_denominator - in - {account_state with staking_delegate_denominator} - in - let add_change pkh update ~f changes = - let delta_pt, delta_mul = - match - (update - : Protocol.Alpha_context.Staking_pseudotoken.t - Protocol.Alpha_context.Receipt.balance_update) - with - | Credited pt -> (pt, Z.one) - | Debited pt -> (pt, Z.minus_one) - in - let delta = - Z.mul delta_mul - @@ Protocol.Alpha_context.Staking_pseudotoken.Internal_for_tests.to_z - delta_pt - in - let f = f delta in - Signature.Public_key_hash.Map.update - pkh - (function - | None -> Some f - | Some existing_change -> - Some (fun account_state -> f (existing_change account_state))) - changes - in - let changes = - List.fold_left - (fun changes balance_update -> - let (Protocol.Alpha_context.Receipt.Balance_update_item - (balance, update, _origin)) = - balance_update - in - match balance with - | Staking_delegator_numerator {delegator} -> ( - match delegator with - | Originated _ -> assert false - | Implicit pkh -> - add_change - pkh - update - changes - ~f:update_staking_delegator_numerator) - | Staking_delegate_denominator {delegate} -> - add_change - delegate - update - changes - ~f:update_staking_delegate_denominator - | _ -> ( - match Protocol.Alpha_context.Receipt.token_of_balance balance with - | Tez -> changes - | Staking_pseudotoken -> assert false)) - Signature.Public_key_hash.Map.empty - balance_updates - in - let update_account account_state = - match Signature.Public_key_hash.Map.find account_state.pkh changes with - | None -> account_state - | Some f -> f account_state - in - let log_updates = - List.map - (fun (x, _) -> fst @@ find_account_from_pkh x state) - (Signature.Public_key_hash.Map.bindings changes) - in - update_map ~log_updates ~f:(String.Map.map update_account) state - - let apply_slashing - ( culprit, - Protocol.Denunciations_repr.{rewarded; misbehaviour; operation_hash} ) - (state : t) : t * Tez.t = - let account_map, total_burnt = - apply_slashing - (culprit, {rewarded; misbehaviour; operation_hash}) - state.constants - state.account_map - in - (* TODO: add culprit's stakers *) - let log_updates = - List.map - (fun x -> fst @@ find_account_from_pkh x state) - [culprit; rewarded] - in - let state = update_map ~log_updates ~f:(fun _ -> account_map) state in - (state, total_burnt) - - let apply_all_slashes_at_cycle_end current_cycle (state : t) : t = - let to_slash_later, to_slash_now = - if - not - state.constants - .Protocol.Alpha_context.Constants.Parametric.adaptive_issuance - .ns_enable - then ([], state.pending_slashes) - else - List.partition - (fun (_, Protocol.Denunciations_repr.{misbehaviour; _}) -> - let cycle = - Block.current_cycle_of_level - ~blocks_per_cycle: - state.constants - .Protocol.Alpha_context.Constants.Parametric - .blocks_per_cycle - ~current_level: - (Protocol.Raw_level_repr.to_int32 misbehaviour.level) - in - Cycle.(cycle = current_cycle)) - state.pending_slashes - in - let state, total_burnt = - List.fold_left - (fun (acc_state, acc_total) x -> - let state, burnt = apply_slashing x acc_state in - (state, Tez.(acc_total +! burnt))) - (state, Tez.zero) - to_slash_now - in - let total_supply = Tez.(state.total_supply -! total_burnt) in - {state with pending_slashes = to_slash_later; total_supply} - - (** Given an account name and new account state, updates [state] accordingly - Preferably use other specific update functions *) - let update_account (account_name : string) (value : account_state) (state : t) - : t = - let account_map = String.Map.add account_name value state.account_map in - {state with account_map} - - let update_delegate account_name delegate_name_opt state : t = - let account = find_account account_name state in - update_account - account_name - {account with delegate = delegate_name_opt} - state - - let add_pending_operations operations state = - {state with pending_operations = state.pending_operations @ operations} - - let pop_pending_operations state = - ({state with pending_operations = []}, state.pending_operations) - - let log_model_autostake name pkh old_cycle op ~optimal amount = - Log.debug - "Model Autostaking: at end of cycle %a, %s(%a) to reach optimal stake %a \ - %s %a" - Cycle.pp - old_cycle - name - Signature.Public_key_hash.pp - pkh - Tez.pp - optimal - op - Tez.pp - (Tez.of_mutez_exn amount) - - let apply_autostake ~name ~old_cycle - ({ - pkh; - contract = _; - delegate; - parameters = _; - liquid; - bonds = _; - frozen_deposits; - unstaked_frozen; - unstaked_finalizable; - staking_delegator_numerator = _; - staking_delegate_denominator = _; - frozen_rights = _; - slashed_cycles = _; - } : - account_state) state = - let open Result_syntax in - if Some name <> delegate then ( - Log.debug - "Model Autostaking: %s <> %s, noop@." - name - (Option.value ~default:"None" delegate) ; - return state) - else - let* current_liquid_delegated = liquid_delegated ~name state in - let current_frozen = Frozen_tez.total_current frozen_deposits in - let current_unstaked_frozen_delegated = - Unstaked_frozen.sum_current unstaked_frozen - in - let current_unstaked_final_delegated = - Unstaked_finalizable.total unstaked_finalizable - in - let power = - Tez.( - current_liquid_delegated +! current_frozen - +! current_unstaked_frozen_delegated - +! current_unstaked_final_delegated - |> to_mutez |> Z.of_int64) - in - let optimal = - Tez.of_z - (Z.cdiv - power - (Z.of_int (state.constants.limit_of_delegation_over_baking + 1))) - in - let autostaked = - Int64.(sub (Tez.to_mutez optimal) (Tez.to_mutez current_frozen)) - in - let state = apply_unslashable (Cycle.succ old_cycle) name state in - let state = apply_finalize name state in - (* stake or unstake *) - let new_state = - if autostaked > 0L then ( - log_model_autostake ~optimal name pkh old_cycle "stake" autostaked ; - apply_stake - Tez.(min liquid (of_mutez autostaked)) - (Cycle.succ old_cycle) - name - state) - else if autostaked < 0L then ( - log_model_autostake - ~optimal - name - pkh - old_cycle - "unstake" - (Int64.neg autostaked) ; - apply_unstake - (Cycle.succ old_cycle) - (Test_tez.of_mutez_exn Int64.(neg autostaked)) - name - state) - else ( - log_model_autostake - ~optimal - name - pkh - old_cycle - "only finalize" - autostaked ; - state) - in - return new_state - - (** Applies when baking the last block of a cycle *) - let apply_end_cycle current_cycle block state : t tzresult Lwt.t = - let open Lwt_result_wrap_syntax in - Log.debug ~color:time_color "Ending cycle %a" Cycle.pp current_cycle ; - let* launch_cycle_opt = - Context.get_adaptive_issuance_launch_cycle (B block) - in - (* Apply all slashes *) - let state = apply_all_slashes_at_cycle_end current_cycle state in - (* Sets initial frozen for future cycle *) - let state = - update_map - ~f: - (update_frozen_rights_cycle - (Cycle.add - current_cycle - (state.constants.consensus_rights_delay + 1))) - state - in - (* Apply autostaking *) - let*?@ state = - if not state.constants.adaptive_issuance.autostaking_enable then Ok state - else - match launch_cycle_opt with - | Some launch_cycle when Cycle.(current_cycle >= launch_cycle) -> - Ok state - | None | Some _ -> - String.Map.fold_e - (fun name account state -> - apply_autostake ~name ~old_cycle:current_cycle account state) - state.account_map - state - in - (* Apply parameter changes *) - let state, param_requests = - List.fold_left - (fun (state, remaining_requests) (name, params, wait) -> - if wait > 0 then - (state, (name, params, wait - 1) :: remaining_requests) - else - let src = find_account name state in - let state = - update_account name {src with parameters = params} state - in - (state, remaining_requests)) - (state, []) - state.param_requests - in - return {state with param_requests} - - (** Applies when baking the first block of a cycle. - Technically nothing special happens, but we need to update the unslashable unstakes - since it's done lazily *) - let apply_new_cycle new_cycle state : t = - apply_unslashable_for_all new_cycle state - - (* end module State *) -end - -(* ======== Scenarios ======== *) - -(** Usual threaded state for the tests. Contains the current block, pending operations - and the known [State.t] *) -type t = Block.t * State.t - -(** A scenario is a succession of actions. We define a branching path as a way to create multiple tests - from the same point. This allows easy compositionality of behaviors with minimal code sharing. - The [Tag] allows to give meaningful identifiers to the branches. It is good practice to tag each - case in a branch (it's not necessary, but since test names must be unique, at most one branch can - remain unnamed, and even then it can create conflicting names.) - *) -type ('input, 'output) scenarios = - | Action : ('input -> 'output tzresult Lwt.t) -> ('input, 'output) scenarios - | Empty : ('t, 't) scenarios - | Concat : (('a, 'b) scenarios * ('b, 'c) scenarios) -> ('a, 'c) scenarios - | Branch : (('a, 'b) scenarios * ('a, 'b) scenarios) -> ('a, 'b) scenarios - | Tag : (* Name for test branch *) string -> ('t, 't) scenarios - | Slow : (* If in scenario branch, makes the test `Slow *) - ('t, 't) scenarios - -(** Unfolded scenario type *) -type ('input, 'output) single_scenario = - | End_scenario : ('t, 't) single_scenario - | Cons : - (('input -> 't tzresult Lwt.t) * ('t, 'output) single_scenario) - -> ('input, 'output) single_scenario - -let rec cat_ss : - type a b c. - (a, b) single_scenario -> (b, c) single_scenario -> (a, c) single_scenario = - fun a b -> - match a with End_scenario -> b | Cons (act, a') -> Cons (act, cat_ss a' b) - -let combine f l1 l2 = - List.map (fun a -> List.map (fun b -> f a b) l2) l1 |> List.flatten - -let rec unfold_scenarios : - type input output. - (input, output) scenarios -> - ((input, output) single_scenario * string list * bool) list = function - | Slow -> [(End_scenario, [], true)] - | Tag s -> [(End_scenario, [s], false)] - | Empty -> [(End_scenario, [], false)] - | Action a -> [(Cons (a, End_scenario), [], false)] - | Branch (left, right) -> unfold_scenarios left @ unfold_scenarios right - | Concat (left, right) -> - let l = unfold_scenarios left in - let r = unfold_scenarios right in - combine - (fun (sl, tl, bl) (sr, tr, br) -> (cat_ss sl sr, tl @ tr, bl || br)) - l - r - -let rec run_scenario : - type input output. - (input, output) single_scenario -> input -> output tzresult Lwt.t = - let open Lwt_result_syntax in - fun scenario input -> - match scenario with - | End_scenario -> return input - | Cons (action, next) -> - let* result = action input in - run_scenario next result - -let unfolded_to_test : - (unit, unit) single_scenario * string list * bool -> - unit Alcotest_lwt.test_case = - fun (s, name, b) -> - let speed = if b then `Slow else `Quick in - let name = - match name with - | [] -> "" - | [n] -> n - | title :: tags -> - (* We chose to separate all tags with a comma, and use the head tag as a title for the test *) - title ^ ": " ^ String.concat ", " tags - in - Tztest.tztest name speed (run_scenario s) - -(** Useful aliases and operators *) - -(* Aliases for [Empty]. Can be used as first component of a scenario instead of a tag if its not needed. *) -let noop = Empty - -let no_tag = Empty - -let concat : - type a b c. (a, b) scenarios -> (b, c) scenarios -> (a, c) scenarios = - fun a b -> - match (a, b) with - | Empty, Empty -> Empty - | _, Empty -> a - | Empty, _ -> b - | _ -> Concat (a, b) - -let branch : type a b. (a, b) scenarios -> (a, b) scenarios -> (a, b) scenarios - = - fun a b -> match (a, b) with Empty, Empty -> Empty | _ -> Branch (a, b) - -(** Continuation connector: execute a then b *) -let ( --> ) a b = concat a b - -(** Branching connector: creates two tests with different execution paths *) -let ( |+ ) a b = branch a b - -let list_to_branch (list : (string * 'a) list) : (unit, 'a) scenarios = - match list with - | [] -> - Stdlib.failwith - (Format.asprintf - "%s: Cannot build scenarios from\n empty list" - __LOC__) - | (tag, h) :: t -> - List.fold_left - (fun scenarios (tag, elt) -> - scenarios - |+ Tag tag --> Action (fun () -> Lwt_result_syntax.return elt)) - (Tag tag --> Action (fun () -> Lwt_result_syntax.return h)) - t - -(** Ends the test. Dump the state, returns [unit] *) -let end_test : ('a, unit) scenarios = - let open Lwt_result_syntax in - Action - (fun _ -> - Log.info ~color:begin_end_color "-- End test --" ; - return_unit) - -(** Transforms scenarios into Alcotest tests *) -let tests_of_scenarios : - (string * (unit, 't) scenarios) list -> unit Alcotest_lwt.test_case list = - fun scenarios -> - List.map (fun (s, x) -> Tag s --> x --> end_test) scenarios |> function - | [] -> [] - | a :: t -> - List.fold_left ( |+ ) a t |> unfold_scenarios |> List.map unfolded_to_test - -(** Arbitrary execution *) -let exec f = Action f - -(** Execute a function that does not modify the block, only the state *) -let exec_state f = - let open Lwt_result_syntax in - Action - (fun ((block, _state) as input) -> - let* state = f input in - return (block, state)) - -(** Execute a function that does not modify neither the block nor the state. - Usually used for checks/asserts *) -let exec_unit f = - let open Lwt_result_syntax in - Action - (fun input -> - let* () = f input in - return input) - -(* ======== Baking ======== *) - -(** After baking and applying rewards in state *) -let check_all_balances block state : unit tzresult Lwt.t = - let open Lwt_result_syntax in - let State.{account_map; total_supply; _} = state in - let* actual_total_supply = Context.get_total_supply (B block) in - let*! r1 = - String.Map.fold_s - (fun name account acc -> - log_debug_balance name account_map ; - let* () = log_debug_rpc_balance name (Implicit account.pkh) block in - let*! r = - assert_balance_check ~loc:__LOC__ (B block) name account_map - in - join_errors r acc) - account_map - Result.return_unit - in - let*! r2 = - Assert.equal - ~loc:__LOC__ - Tez.equal - "Total supplies do not match" - Tez.pp - actual_total_supply - total_supply - in - join_errors r1 r2 - -let check_issuance_rpc block : unit tzresult Lwt.t = - let open Lwt_result_syntax in - (* We assume one block per minute *) - let* rewards_per_block = Context.get_issuance_per_minute (B block) in - let* total_supply = Context.get_total_supply (B block) in - let* expected_issuance = Context.get_ai_expected_issuance (B block) in - let* () = - match expected_issuance with - | ei :: _ -> - (* We assume only the fixed portion is issued *) - Assert.equal_tez - ~loc:__LOC__ - rewards_per_block - ei.baking_reward_fixed_portion - | _ -> failwith "expected_issuance rpc: unexpected value" - in - let* yearly_rate = Context.get_ai_current_yearly_rate (B block) in - let* yearly_rate_exact = Context.get_ai_current_yearly_rate_exact (B block) in - let yr = float_of_string yearly_rate in - let yre = Q.to_float yearly_rate_exact in - (* Precision for yearly rate is 0.001 *) - let* () = - Assert.equal - ~loc:__LOC__ - (fun x y -> Float.(abs (x -. y) <= 0.001)) - "Yearly rate (float)" - Format.pp_print_float - yr - yre - in - (* Divided by 525_600 minutes per year, x100 because rpc returns a pct *) - let issuance_from_rate = - Tez.( - mul_q total_supply Q.(div yearly_rate_exact ~$525_600_00) - |> of_q ~round_up:false) - in - let* () = - Assert.equal - ~loc:__LOC__ - Tez.equal - "Issuance" - Tez.pp - rewards_per_block - issuance_from_rate - in - return_unit - -(** Bake a block, with the given baker and the given operations. *) -let bake ?baker : t -> t tzresult Lwt.t = - fun (block, state) -> - let open Lwt_result_wrap_syntax in - Log.info - ~color:time_color - "Baking level %d" - (Int32.to_int (Int32.succ Block.(block.header.shell.level))) ; - let current_cycle = Block.current_cycle block in - let adaptive_issuance_vote = - if state.activate_ai then - Protocol.Alpha_context.Per_block_votes.Per_block_vote_on - else Per_block_vote_pass - in - let policy = - match baker with - | None -> state.baking_policy - | Some baker -> - let {pkh; _} = - try State.find_account baker state - with Not_found -> - Log.info - ~color:warning_color - "Invalid baker: %s not found. Aborting" - baker ; - assert false - in - Some (Block.By_account pkh) - in - let* baker, _, _, _ = Block.get_next_baker ?policy block in - let baker_name, {contract = baker_contract; _} = - State.find_account_from_pkh baker state - in - let* () = check_issuance_rpc block in - let state, operations = State.pop_pending_operations state in - let* block, state = - let* block', metadata = - Block.bake_with_metadata ?policy ~adaptive_issuance_vote ~operations block - in - let balance_updates = Block.get_balance_updates_from_metadata metadata in - let state = - State.apply_staking_abstract_balance_updates balance_updates state - in - if state.burn_rewards then - (* Incremental mode *) - let* i = - Incremental.begin_construction ?policy ~adaptive_issuance_vote block - in - let* block_rewards = Context.get_issuance_per_minute (B block') in - let ctxt = Incremental.alpha_ctxt i in - let*@ context, _ = - Protocol.Alpha_context.Token.transfer - ctxt - (`Contract baker_contract) - `Burned - block_rewards - in - let i = Incremental.set_alpha_ctxt i context in - let* i = List.fold_left_es Incremental.add_operation i operations in - let* block = Incremental.finalize_block i in - let state = State.apply_burn block_rewards baker_name state in - return (block, state) - else return (block', state) - in - let* state = State.apply_rewards ~baker:baker_name block state in - (* First block of a new cycle *) - let new_current_cycle = Block.current_cycle block in - let* state = - if Protocol.Alpha_context.Cycle.(current_cycle = new_current_cycle) then - return state - else ( - Log.info - ~color:time_color - "Cycle %d" - (Protocol.Alpha_context.Cycle.to_int32 new_current_cycle |> Int32.to_int) ; - return @@ State.apply_new_cycle new_current_cycle state) - in - (* Dawn of a new cycle *) - let* state = - if not (Block.last_block_of_cycle block) then return state - else State.apply_end_cycle current_cycle block state - in - let* () = check_all_balances block state in - return (block, state) - -(** Bake until a cycle is reached, using [bake] instead of [Block.bake] - Should be slower because checks balances at the end of every block (avoidable in some cases) *) -let bake_until_next_cycle : t -> t tzresult Lwt.t = - fun (init_block, init_state) -> - let open Lwt_result_syntax in - let current_cycle = Block.current_cycle init_block in - let rec step (old_block, old_state) = - let step_cycle = Block.current_cycle old_block in - if Protocol.Alpha_context.Cycle.(step_cycle > current_cycle) then - return (old_block, old_state) - else - let* new_block, new_state = bake (old_block, old_state) in - step (new_block, new_state) - in - step (init_block, init_state) - -(* ======== State updates ======== *) - -(** Sets the de facto baker for all future blocks *) -let set_baker baker : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (_block, state) -> - let {pkh; _} = State.find_account baker state in - return {state with State.baking_policy = Some (Block.By_account pkh)}) - -(** Exclude a list of delegates from baking *) -let exclude_bakers bakers : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (_block, state) -> - let bakers_pkh = - List.map (fun baker -> (State.find_account baker state).pkh) bakers - in - return - {state with State.baking_policy = Some (Block.Excluding bakers_pkh)}) - -(** Unsets the baking policy, it returns to default ([By_round 0]) *) -let unset_baking_policy : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (_block, state) -> - return {state with State.baking_policy = None}) - -(** Creates a snapshot of the current balances for the given account names. - Can be used to check that balances at point A and B in the execution of a test - are the same (either nothing happened, or a succession of actions resulted in - getting the same values as before *) -let snapshot_balances snap_name names_list : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (_block, state) -> - Log.debug - ~color:low_debug_color - "Snapshoting balances as \"%s\"" - snap_name ; - let balances = - List.map - (fun name -> (name, balance_of_account name state.State.account_map)) - names_list - in - let snapshot_balances = - String.Map.add snap_name balances state.snapshot_balances - in - return {state with snapshot_balances}) - -(** Check balances against a previously defined snapshot *) -let check_snapshot_balances - ?(f = - fun ~name ~old_balance ~new_balance -> - assert_balance_equal ~loc:__LOC__ name old_balance new_balance) - snap_name : (t, t) scenarios = - let open Lwt_result_syntax in - exec_unit (fun (_block, state) -> - Log.debug - ~color:low_debug_color - "Checking evolution of balances between \"%s\" and now" - snap_name ; - let snapshot_balances = - String.Map.find snap_name state.State.snapshot_balances - in - match snapshot_balances with - | None -> - Log.debug - ~color:warning_color - "\"%s\" snapshot not found..." - snap_name ; - return_unit - | Some snapshot_balances -> - let* () = - List.iter_es - (fun (name, old_balance) -> - let new_balance = - balance_of_account name state.State.account_map - in - f ~name ~old_balance ~new_balance) - snapshot_balances - in - return_unit) - -(** Save the current issuance rate for future use *) -let save_current_rate : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (block, state) -> - let* rate = Context.get_ai_current_yearly_rate_exact (B block) in - return {state with State.saved_rate = Some rate}) - -(** Check that [f saved_rate current_rate] is true. [f] is typically a comparison function *) -let check_rate_evolution (f : Q.t -> Q.t -> bool) : (t, t) scenarios = - let open Lwt_result_syntax in - exec_unit (fun (block, state) -> - let* new_rate = Context.get_ai_current_yearly_rate_exact (B block) in - let previous_rate = state.State.saved_rate in - match previous_rate with - | None -> failwith "check_rate_evolution: no rate previously saved" - | Some previous_rate -> - if f previous_rate new_rate then return_unit - else - failwith - "check_rate_evolution: assertion failed@.previous rate: %a@.new \ - rate: %a" - Q.pp_print - previous_rate - Q.pp_print - new_rate) - -(* ======== Operations ======== *) - -(** Bake a single block *) -let next_block = - exec (fun input -> - Log.info ~color:action_color "[Next block]" ; - bake input) - -(** Bake a single block with a specific baker *) -let next_block_with_baker baker = - exec (fun input -> - Log.info ~color:action_color "[Next block (baker %s)]" baker ; - bake ~baker input) - -(** Bake until the end of a cycle *) -let next_cycle = - exec (fun input -> - Log.info ~color:action_color "[Next cycle]" ; - bake_until_next_cycle input) - -(** Executes an operation: f should return a new state and a list of operations, which are then applied *) -let exec_op f = - let open Lwt_result_syntax in - Action - (fun ((block, _state) as input) -> - let* state, ops = f input in - let state = State.add_pending_operations ops state in - return (block, state)) - --> next_block - -(* ======== Definition of basic actions ======== *) - -(** Initialize the test, given some initial parameters *) -let begin_test ~activate_ai ?(burn_rewards = false) ?(ns_enable_fork = false) - ?(constants : Protocol.Alpha_context.Constants.Parametric.t option) - ?(constants_list : - (string * Protocol.Alpha_context.Constants.Parametric.t) list option) - delegates_name_list : (unit, t) scenarios = - let f ns_enable = - (match (constants, constants_list) with - | None, None -> Stdlib.failwith "No constants provided to begin_test" - | Some _, Some _ -> - Stdlib.failwith - "You cannot provide ~constants and ~constants_list to begin_test" - | None, Some constants_list -> list_to_branch constants_list - | Some constants, None -> - Action (fun () -> Lwt_result_syntax.return constants)) - --> exec (fun (constants : Protocol.Alpha_context.Constants.Parametric.t) -> - let open Lwt_result_syntax in - Log.info ~color:begin_end_color "-- Begin test --" ; - let bootstrap = "__bootstrap__" in - let delegates_name_list = bootstrap :: delegates_name_list in - (* Override threshold value if activate *) - let constants = - if activate_ai then ( - Log.info ~color:event_color "Setting ai threshold to 0" ; - { - constants with - adaptive_issuance = - { - constants.adaptive_issuance with - launch_ema_threshold = 0l; - activation_vote_enable = true; - ns_enable; - }; - }) - else constants - in - let n = List.length delegates_name_list in - let* block, delegates = Context.init_with_constants_n constants n in - let*? init_level = Context.get_level (B block) in - let init_staked = Tez.of_mutez 200_000_000_000L in - let*? account_map = - List.fold_left2 - ~when_different_lengths: - [Inconsistent_number_of_bootstrap_accounts] - (fun account_map name contract -> - let liquid = - Tez.(Account.default_initial_balance -! init_staked) - in - let frozen_deposits = Frozen_tez.init init_staked name name in - let frozen_rights = - List.fold_left - (fun map cycle -> CycleMap.add cycle init_staked map) - CycleMap.empty - Cycle.( - root ---> add root constants.consensus_rights_delay) - in - let pkh = Context.Contract.pkh contract in - let account = - init_account - ~delegate:name - ~pkh - ~contract - ~parameters:default_params - ~liquid - ~frozen_deposits - ~frozen_rights - () - in - let account_map = String.Map.add name account account_map in - let balance, total_balance = - balance_and_total_balance_of_account name account_map - in - Log.debug - "Initial balance for %s:\n%a" - name - balance_pp - balance ; - Log.debug "Initial total balance: %a" Tez.pp total_balance ; - account_map) - String.Map.empty - delegates_name_list - delegates - in - let* total_supply = Context.get_total_supply (B block) in - let state = - State. - { - account_map; - total_supply; - constants; - param_requests = []; - activate_ai; - baking_policy = None; - last_level_rewards = init_level; - snapshot_balances = String.Map.empty; - saved_rate = None; - burn_rewards; - pending_operations = []; - pending_slashes = []; - double_signings = []; - } - in - let* () = check_all_balances block state in - return (block, state)) - in - if ns_enable_fork then - Tag "ns_enable = true" --> f true |+ Tag "ns_enable = false" --> f false - else f false - -(** Set delegate parameters for the given delegate *) -let set_delegate_params delegate_name parameters : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - (* Simple example of action_atom definition: *) - let delegate = State.find_account delegate_name state in - Log.info - ~color:action_color - "[Set delegate parameters for \"%s\"]" - delegate_name ; - (* Define the operation *) - let* operation = - set_delegate_parameters (B block) delegate.contract ~parameters - in - (* Update state *) - let wait = state.constants.delegate_parameters_activation_delay - 1 in - let state = - { - state with - param_requests = - (delegate_name, parameters, wait) :: state.param_requests; - } - in - (* Return both *) - return (state, [operation])) - -(** Add a new account with the given name *) -let add_account name : (t, t) scenarios = - let open Lwt_result_syntax in - exec_state (fun (_block, state) -> - Log.info ~color:action_color "[Add account \"%s\"]" name ; - let new_account = Account.new_account () in - let pkh = new_account.pkh in - let contract = Protocol.Alpha_context.Contract.Implicit pkh in - let account_state = - init_account ~pkh ~contract ~parameters:default_params () - in - let state = State.update_account name account_state state in - return state) - -(** Reveal operation *) -let reveal name : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let account = State.find_account name state in - Log.info ~color:action_color "[Reveal \"%s\"]" name ; - let* acc = Account.find account.pkh in - let* operation = - Op.revelation ~fee:Protocol.Alpha_context.Tez.zero (B block) acc.pk - in - return (state, [operation])) - -(** Transfer from src to dst *) -let transfer src_name dst_name amount : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let src = State.find_account src_name state in - let dst = State.find_account dst_name state in - let amount = quantity_to_tez src.liquid amount in - Log.info - ~color:action_color - "[Transfer \"%s\" -> \"%s\" (%aꜩ)]" - src_name - dst_name - Tez.pp - amount ; - let* operation = - Op.transaction ~fee:Tez.zero (B block) src.contract dst.contract amount - in - let state = State.apply_transfer amount src_name dst_name state in - return (state, [operation])) - -(** Set delegate for src. If [delegate_name_opt = None], then unset current delegate *) -let set_delegate src_name delegate_name_opt : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let src = State.find_account src_name state in - let delegate_pkh_opt = - match delegate_name_opt with - | None -> - Log.info ~color:action_color "[Unset delegate of \"%s\"]" src_name ; - None - | Some delegate_name -> - let delegate = State.find_account delegate_name state in - Log.info - ~color:action_color - "[Set delegate \"%s\" for \"%s\"]" - delegate_name - src_name ; - Some delegate.pkh - in - let cycle = Block.current_cycle block in - let* operation = - Op.delegation ~fee:Tez.zero (B block) src.contract delegate_pkh_opt - in - let balance = balance_of_account src_name state.account_map in - let state = - if Q.(equal balance.staked_b zero) then state - else - let state = State.apply_unstake cycle Tez.max_mutez src_name state in - (* Changing delegate applies finalize if unstake happened *) - State.apply_finalize src_name state - in - let state = State.update_delegate src_name delegate_name_opt state in - return (state, [operation])) - -(** Stake operation *) -let stake src_name stake_value : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let src = State.find_account src_name state in - Log.info - ~color:action_color - "[Stake for \"%s\" (%a)]" - src_name - tez_quantity_pp - stake_value ; - (* Stake applies finalize *before* the stake *) - let state = State.apply_finalize src_name state in - let amount = quantity_to_tez src.liquid stake_value in - let current_cycle = Block.current_cycle block in - let* operation = stake (B block) src.contract amount in - let state = State.apply_stake amount current_cycle src_name state in - return (state, [operation])) - -(** unstake operation *) -let unstake src_name unstake_value : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let src = State.find_account src_name state in - Log.info - ~color:action_color - "[Unstake for \"%s\" (%a)]" - src_name - tez_quantity_pp - unstake_value ; - let stake_balance = - (balance_of_account src_name state.account_map).staked_b - |> Partial_tez.to_tez ~round_up:false - in - let amount = quantity_to_tez stake_balance unstake_value in - let* operation = unstake (B block) src.contract amount in - let cycle = Block.current_cycle block in - let balance = balance_of_account src_name state.account_map in - let state = - if Q.(equal balance.staked_b zero) then state - else - let state = State.apply_unstake cycle amount src_name state in - State.apply_finalize src_name state - in - return (state, [operation])) - -(** finalize unstake operation *) -let finalize_unstake src_name : (t, t) scenarios = - exec_op (fun (block, state) -> - let open Lwt_result_syntax in - let src = State.find_account src_name state in - Log.info ~color:action_color "[Finalize_unstake for \"%s\"]" src_name ; - let* operation = finalize_unstake (B block) src.contract in - let state = State.apply_finalize src_name state in - return (state, [operation])) - -(* ======== Slashing ======== *) - -let check_pending_slashings (block, state) : unit tzresult Lwt.t = - let open Lwt_result_syntax in - let open Protocol.Denunciations_repr in - let* denunciations_rpc = Context.get_denunciations (B block) in - let denunciations_obj_equal (pkh_1, {rewarded = r1; misbehaviour = m1; _}) - (pkh_2, {rewarded = r2; misbehaviour = m2; _}) = - Signature.Public_key_hash.equal pkh_1 pkh_2 - && Signature.Public_key_hash.equal r1 r2 - && Stdlib.(m1.kind = m2.kind) - in - let compare_denunciations (pkh_1, {rewarded = r1; misbehaviour = m1; _}) - (pkh_2, {rewarded = r2; misbehaviour = m2; _}) = - let c1 = Signature.Public_key_hash.compare pkh_1 pkh_2 in - if c1 <> 0 then c1 - else - let c2 = Signature.Public_key_hash.compare r1 r2 in - if c2 <> 0 then c2 - else Protocol.Misbehaviour_repr.compare_kind m1.kind m2.kind - in - let denunciations_rpc = List.sort compare_denunciations denunciations_rpc in - let denunciations_state = - List.sort compare_denunciations state.State.pending_slashes - in - let denunciations_equal = List.equal denunciations_obj_equal in - let denunciations_obj_pp fmt - (pkh, {rewarded; misbehaviour; operation_hash = _}) = - Format.fprintf - fmt - "slashed: %a; rewarded: %a; kind: %s@." - Signature.Public_key_hash.pp - pkh - Signature.Public_key_hash.pp - rewarded - (match misbehaviour.kind with - | Double_baking -> "double baking" - | Double_attesting -> "double attesting" - | Double_preattesting -> "double preattesting") - in - let denunciations_pp = Format.pp_print_list denunciations_obj_pp in - let* () = - Assert.equal - ~loc:__LOC__ - denunciations_equal - "Denunciations are not equal" - denunciations_pp - denunciations_rpc - denunciations_state - in - return_unit - -(** Double attestation helpers *) -let order_attestations ~correct_order op1 op2 = - let oph1 = Protocol.Alpha_context.Operation.hash op1 in - let oph2 = Protocol.Alpha_context.Operation.hash op2 in - let c = Operation_hash.compare oph1 oph2 in - if correct_order then if c < 0 then (op1, op2) else (op2, op1) - else if c < 0 then (op2, op1) - else (op1, op2) - -let op_double_attestation ?(correct_order = true) op1 op2 ctxt = - let e1, e2 = order_attestations ~correct_order op1 op2 in - Op.double_attestation ctxt e1 e2 - -let op_double_preattestation ?(correct_order = true) op1 op2 ctxt = - let e1, e2 = order_attestations ~correct_order op1 op2 in - Op.double_preattestation ctxt e1 e2 - -let order_block_hashes ~correct_order bh1 bh2 = - let hash1 = Protocol.Alpha_context.Block_header.hash bh1 in - let hash2 = Protocol.Alpha_context.Block_header.hash bh2 in - let c = Block_hash.compare hash1 hash2 in - if correct_order then if c < 0 then (bh1, bh2) else (bh2, bh1) - else if c < 0 then (bh2, bh1) - else (bh1, bh2) - -let op_double_baking ?(correct_order = true) bh1 bh2 ctxt = - let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in - Op.double_baking ctxt bh1 bh2 - -let double_bake_ delegate_name (block, state) = - let open Lwt_result_syntax in - Log.info ~color:Log_module.event_color "Double baking with %s" delegate_name ; - let delegate = State.find_account delegate_name state in - let* operation = - Adaptive_issuance_helpers.unstake (B block) delegate.contract Tez.one_mutez - in - let* forked_block = - Block.bake ~policy:(By_account delegate.pkh) ~operation block - in - (* includes pending operations *) - let* main_branch, state = bake ~baker:delegate_name (block, state) in - let evidence = op_double_baking main_branch.header forked_block.header in - let dss = - { - culprit = delegate.pkh; - denounced = false; - evidence; - kind = Double_baking; - level = block.header.shell.level; - } - in - let state = - {state with double_signings = dss :: state.State.double_signings} - in - return (main_branch, state) - -(* Note: advances one block *) -let double_bake delegate_name : (t, t) scenarios = - exec (double_bake_ delegate_name) - -(* [other_bakers] can be used to force using specific bakers to avoid - reusing forbidden ones *) -let double_attest_op ?other_bakers ~op ~op_evidence ~kind delegate_name - (block, state) = - let open Lwt_result_syntax in - Log.info - ~color:Log_module.event_color - "Double %s with %s" - (match kind with - | Protocol.Misbehaviour_repr.Double_preattesting -> "preattesting" - | Double_attesting -> "attesting" - | Double_baking -> assert false) - delegate_name ; - let delegate = State.find_account delegate_name state in - let* baker, _, _, _ = - Block.get_next_baker ?policy:state.baking_policy block - in - let* other_baker1, other_baker2 = - match other_bakers with - | Some (ob1, ob2) -> - let ob1 = (State.find_account ob1 state).pkh in - let ob2 = (State.find_account ob2 state).pkh in - return (ob1, ob2) - | None -> Context.get_first_different_bakers (B block) - in - let other_baker = - if not (Signature.Public_key_hash.equal baker other_baker2) then - other_baker2 - else other_baker1 - in - let* forked_block = Block.bake ~policy:(By_account other_baker) block in - let* forked_block = Block.bake ?policy:state.baking_policy forked_block in - (* includes pending operations *) - let* block, state = bake (block, state) in - let* main_branch, state = bake (block, state) in - let* attestation_a = op ~delegate:delegate.pkh forked_block in - let* attestation_b = op ~delegate:delegate.pkh main_branch in - let evidence = op_evidence attestation_a attestation_b in - let dss = - { - culprit = delegate.pkh; - denounced = false; - evidence; - kind; - level = block.header.shell.level; - } - in - let state = - {state with double_signings = dss :: state.State.double_signings} - in - return (main_branch, state) - -let double_attest_ = - double_attest_op - ~op:(fun ~delegate block -> Op.raw_attestation ~delegate block) - ~op_evidence:op_double_attestation - ~kind:Double_attesting - -(* Note: advances two blocks *) -let double_attest ?other_bakers delegate_name : (t, t) scenarios = - exec (double_attest_ ?other_bakers delegate_name) - -let double_preattest_ = - double_attest_op - ~op:(fun ~delegate block -> Op.raw_preattestation ~delegate block) - ~op_evidence:op_double_preattestation - ~kind:Double_preattesting - -(* Note: advances two blocks *) -let double_preattest ?other_bakers delegate_name : (t, t) scenarios = - exec (double_preattest_ ?other_bakers delegate_name) - -let cycle_from_level blocks_per_cycle level = - let current_cycle = Int32.div level blocks_per_cycle in - let current_cycle = Cycle.add Cycle.root (Int32.to_int current_cycle) in - current_cycle - -let pct_from_kind (block : Block.t) = function - | Protocol.Misbehaviour_repr.Double_baking -> - Protocol.Percentage.to_q - block.constants.percentage_of_frozen_deposits_slashed_per_double_baking - |> Q.(mul (100 // 1)) - |> Q.to_int - | Double_attesting | Double_preattesting -> - Protocol.Percentage.to_q - block.constants - .percentage_of_frozen_deposits_slashed_per_double_attestation - |> Q.(mul (100 // 1)) - |> Q.to_int - -let get_pending_slashed_pct_for_delegate (block, state) delegate = - let rec aux r = function - | [] -> r - | (culprit, {Protocol.Denunciations_repr.misbehaviour; _}) :: t -> - if Signature.Public_key_hash.equal delegate culprit then - let new_r = r + pct_from_kind block misbehaviour.kind in - if new_r >= 100 then 100 else aux new_r t - else aux r t - in - aux 0 state.State.pending_slashes - -let update_state_denunciation (block, state) - {culprit; denounced; evidence = _; kind; level} = - let open Lwt_result_syntax in - if denounced then - (* If the double signing has already been denounced, a second denunciation should fail *) - return (state, denounced) - else - let*? block_level = Context.get_level (B block) in - let next_level = - Protocol.Alpha_context.Raw_level.(to_int32 @@ succ block_level) - in - if level > next_level then - (* The denunciation is trying to be included too early *) - return (state, denounced) - else - let inclusion_cycle = - cycle_from_level block.constants.blocks_per_cycle next_level - in - let ds_cycle = cycle_from_level block.constants.blocks_per_cycle level in - if Cycle.(succ ds_cycle < inclusion_cycle) then - (* denunciation is too late, gets refused *) - return (state, denounced) - else if get_pending_slashed_pct_for_delegate (block, state) culprit >= 100 - then - (* Culprit has been slashed too much, a denunciation is not added to the list. - TODO: is the double signing treated as included, or can it be included in the - following cycle? *) - return (state, denounced) - else - let misbehaviour = - { - (* Fields level and round are unused for now. *) - level = Protocol.Raw_level_repr.of_int32_exn level; - round = Protocol.Round_repr.zero; - Protocol.Misbehaviour_repr.kind; - } - in - (* for simplicity's sake (lol), the block producer and the payload producer are the same - We also assume that the current state baking policy will be used for the next block *) - let* rewarded, _, _, _ = - Block.get_next_baker ?policy:state.baking_policy block - in - let culprit_name, culprit_account = - State.find_account_from_pkh culprit state - in - let state = - State.update_account - culprit_name - { - culprit_account with - slashed_cycles = inclusion_cycle :: culprit_account.slashed_cycles; - } - state - in - let new_pending_slash = - ( culprit, - { - Protocol.Denunciations_repr.rewarded; - misbehaviour; - operation_hash = Operation_hash.zero; - (* unused *) - } ) - in - (* TODO: better log... *) - Log.info - ~color:Log_module.event_color - "Including denunciation (misbehaviour cycle %a)" - Cycle.pp - ds_cycle ; - let state = - State. - { - state with - pending_slashes = new_pending_slash :: state.pending_slashes; - } - in - return (state, true) - -let make_denunciations_ ?(filter = fun {denounced; _} -> not denounced) - (block, state) = - let open Lwt_result_syntax in - let* () = check_pending_slashings (block, state) in - let make_op state ({evidence; _} as dss) = - if filter dss then - let* state, denounced = update_state_denunciation (block, state) dss in - return (Some (evidence (B block), {dss with denounced}, state)) - else return None - in - let rec make_op_list dss_list state r_op r_dss = - match dss_list with - | d :: t -> ( - let* new_op = make_op state d in - match new_op with - | None -> make_op_list t state r_op (d :: r_dss) - | Some (op, p_dss, new_state) -> - make_op_list t new_state (op :: r_op) (p_dss :: r_dss)) - | [] -> return @@ (state, List.rev r_op, List.rev r_dss) - in - let* state, operations, double_signings = - make_op_list state.double_signings state [] [] - in - let state = {state with double_signings} in - return (state, operations) - -(* Important note: do not change the baking policy behaviour once denunciations are made, - until the operations are included in a block (by default the next block) *) -let make_denunciations ?filter () = exec_op (make_denunciations_ ?filter) - -(* ======== Misc functions ========*) - -let check_failure_aux ?expected_error : - ('a -> 'b tzresult Lwt.t) -> 'a -> 'a tzresult Lwt.t = - let open Lwt_result_syntax in - fun f input -> - Log.info ~color:assert_block_color "Entering failing scenario..." ; - let*! output = f input in - match output with - | Ok _ -> failwith "Unexpected success" - | Error e -> ( - match expected_error with - | None -> - Log.info ~color:assert_block_color "Rollback" ; - return input - | Some exp_e -> - let exp_e = exp_e input in - if e = exp_e then ( - Log.info ~color:assert_block_color "Rollback" ; - return input) - else ( - Log.info - ~color:Log.Color.FG.red - "Unexpected error:@.%a@.Expected:@.%a@." - (Format.pp_print_list pp) - e - (Format.pp_print_list pp) - exp_e ; - tzfail Unexpected_error)) - -let check_fail_and_rollback ?expected_error : - ('a, 'b) single_scenario -> 'a -> 'a tzresult Lwt.t = - fun sc input -> check_failure_aux ?expected_error (run_scenario sc) input - -(** Useful function to test expected failures: runs the given branch until it fails, - then rollbacks to before execution. Fails if the given branch Succeeds *) -let assert_failure ?expected_error : ('a, 'b) scenarios -> ('a, 'a) scenarios = - fun scenarios -> - match unfold_scenarios scenarios with - | [] -> Empty - | [(sc, _, _)] -> exec (check_fail_and_rollback ?expected_error sc) - | _ -> - exec (fun _ -> - failwith "Error: assert_failure used with branching scenario") - -(** Loop *) -let rec loop n : ('a, 'a) scenarios -> ('a, 'a) scenarios = - fun scenario -> - (* If branching scenarios with k branches, returns a scenario with k^n branches *) - if n = 0 then Empty - else if n = 1 then scenario - else loop (n - 1) scenario --> scenario - -let rec loop_action n : ('a -> 'a tzresult Lwt.t) -> ('a, 'a) scenarios = - fun f -> - if n = 0 then Empty - else if n = 1 then exec f - else loop_action (n - 1) f --> exec f - -(** Check a specific balance field for a specific account is equal to a specific amount *) -let check_balance_field src_name field amount : (t, t) scenarios = - let open Lwt_result_syntax in - let check = Assert.equal_tez ~loc:__LOC__ amount in - let check' a = check (Partial_tez.to_tez ~round_up:false a) in - exec_state (fun (block, state) -> - let src = State.find_account src_name state in - let src_balance, src_total = - balance_and_total_balance_of_account src_name state.account_map - in - let* rpc_balance, rpc_total = - get_balance_from_context (B block) src.contract - in - let* () = - match field with - | `Liquid -> - let* () = check rpc_balance.liquid_b in - check src_balance.liquid_b - | `Bonds -> - let* () = check rpc_balance.bonds_b in - check src_balance.bonds_b - | `Staked -> - let* () = check' rpc_balance.staked_b in - check' src_balance.staked_b - | `Unstaked_frozen_total -> - let* () = check rpc_balance.unstaked_frozen_b in - check src_balance.unstaked_frozen_b - | `Unstaked_finalizable -> - let* () = check rpc_balance.unstaked_finalizable_b in - check src_balance.unstaked_finalizable_b - | `Total -> - let* () = check rpc_total in - check src_total - in - return state) - -(** Waiting functions *) -let rec wait_n_cycles n = - if n <= 0 then noop - else if n = 1 then next_cycle - else wait_n_cycles (n - 1) --> next_cycle - -let rec wait_n_blocks n = - if n <= 0 then noop - else if n = 1 then next_block - else wait_n_blocks (n - 1) --> next_block - -(** Wait until we are in a cycle satifying the given condition. - Fails if AI_activation is requested and AI is not set to be activated in the future. *) -let wait_cycle condition = - exec (fun (block, state) -> - let open Lwt_result_syntax in - let rec stopper condition = - match condition with - | `AI_activation -> - if state.State.activate_ai then - let* launch_cycle = get_launch_cycle ~loc:__LOC__ block in - return - @@ ( (fun block _state -> - let current_cycle = Block.current_cycle block in - Cycle.(current_cycle >= launch_cycle)), - "AI activation", - "AI activated" ) - else assert false - | `delegate_parameters_activation -> - let init_cycle = Block.current_cycle block in - let cycles_to_wait = - state.constants.delegate_parameters_activation_delay - in - return - @@ ( (fun block _state -> - Cycle.( - Block.current_cycle block >= add init_cycle cycles_to_wait)), - "delegate parameters activation", - "delegate parameters activated" ) - | `And (cond1, cond2) -> - let* stop1, to1, done1 = stopper cond1 in - let* stop2, to2, done2 = stopper cond2 in - return - @@ ( (fun block state -> stop1 block state && stop2 block state), - to1 ^ " and " ^ to2, - done1 ^ " and " ^ done2 ) - in - let* stopper, to_, done_ = stopper condition in - Log.info ~color:time_color "Fast forward to %s" to_ ; - let* output = - let rec bake_while (block, state) = - if stopper block state then return (block, state) - else - let* input = bake_until_next_cycle (block, state) in - bake_while input - in - bake_while (block, state) - in - Log.info ~color:event_color "%s" done_ ; - return output) - -(** Wait until AI activates. - Fails if AI is not set to be activated in the future. *) -let wait_ai_activation = wait_cycle `AI_activation - -(** wait delegate_parameters_activation_delay cycles *) -let wait_delegate_parameters_activation = - wait_cycle `delegate_parameters_activation - -(** Create an account and give an initial balance funded by [source] *) -let add_account_with_funds name source amount = - add_account name --> transfer source name amount --> reveal name - -(* ======== Scenarios ======== *) - -let test_expected_error = - assert_failure - ~expected_error:(fun _ -> [Exn (Failure "")]) - (exec (fun _ -> failwith "")) - --> assert_failure - ~expected_error:(fun _ -> [Unexpected_error]) - (assert_failure - ~expected_error:(fun _ -> - [Inconsistent_number_of_bootstrap_accounts]) - (exec (fun _ -> failwith ""))) - -let init_constants ?reward_per_block ?(deactivate_dynamic = false) - ?blocks_per_cycle ?delegate_parameters_activation_delay ~autostaking_enable - () = - let reward_per_block = Option.value ~default:0L reward_per_block in - let base_total_issued_per_minute = Tez.of_mutez reward_per_block in - let default_constants = Default_parameters.constants_test in - (* default for tests: 12 *) - let blocks_per_cycle = - Option.value ~default:default_constants.blocks_per_cycle blocks_per_cycle - in - let delegate_parameters_activation_delay = - Option.value - ~default:default_constants.delegate_parameters_activation_delay - delegate_parameters_activation_delay - in - let issuance_weights = - Protocol.Alpha_context.Constants.Parametric. - { - base_total_issued_per_minute; - baking_reward_fixed_portion_weight = 1; - baking_reward_bonus_weight = 0; - attesting_reward_weight = 0; - seed_nonce_revelation_tip_weight = 0; - vdf_revelation_tip_weight = 0; - } - in - let liquidity_baking_subsidy = Tez.zero in - let minimal_block_delay = Protocol.Alpha_context.Period.one_minute in - let cost_per_byte = Tez.zero in - let consensus_threshold = 0 in - let adaptive_issuance = default_constants.adaptive_issuance in - let adaptive_rewards_params = - if deactivate_dynamic then - { - adaptive_issuance.adaptive_rewards_params with - max_bonus = - Protocol.Issuance_bonus_repr.max_bonus_parameter_of_Q_exn Q.zero; - } - else adaptive_issuance.adaptive_rewards_params - in - let adaptive_issuance = - {adaptive_issuance with adaptive_rewards_params; autostaking_enable} - in - { - default_constants with - delegate_parameters_activation_delay; - consensus_threshold; - issuance_weights; - minimal_block_delay; - cost_per_byte; - adaptive_issuance; - blocks_per_cycle; - liquidity_baking_subsidy; - } - -(** Initialization of scenarios with 3 cases: - - AI activated, staker = delegate - - AI activated, staker != delegate - - AI not activated (and staker = delegate) - Any scenario that begins with this will be triplicated. - *) -let init_scenario ?(force_ai = true) ?reward_per_block () = - let constants = - init_constants ?reward_per_block ~autostaking_enable:false () - in - let init_params = - {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} - in - let begin_test ~activate_ai ~self_stake = - let name = if self_stake then "staker" else "delegate" in - begin_test ~activate_ai ~constants [name] - --> set_delegate_params name init_params - --> set_baker "__bootstrap__" - in - let ai_activated = - Tag "AI activated" - --> (Tag "self stake" --> begin_test ~activate_ai:true ~self_stake:true - |+ Tag "external stake" - --> begin_test ~activate_ai:true ~self_stake:false - --> add_account_with_funds - "staker" - "delegate" - (Amount (Tez.of_mutez 2_000_000_000_000L)) - --> set_delegate "staker" (Some "delegate")) - --> wait_ai_activation - in - - let ai_deactivated = - Tag "AI deactivated, self stake" - --> begin_test ~activate_ai:false ~self_stake:true - in - (if force_ai then ai_activated else ai_activated |+ ai_deactivated) - --> next_block - -module Roundtrip = struct - let stake_init = - stake "staker" Half - --> (Tag "no wait after stake" --> Empty - |+ Tag "wait after stake" --> wait_n_cycles 2) - - let wait_for_unfreeze_and_check wait = - snapshot_balances "wait snap" ["staker"] - --> wait_n_cycles (wait - 1) - (* Balance didn't change yet, but will change next cycle *) - --> check_snapshot_balances "wait snap" - --> next_cycle - --> assert_failure (check_snapshot_balances "wait snap") - - let finalize staker = - assert_failure (check_balance_field staker `Unstaked_finalizable Tez.zero) - --> finalize_unstake staker - --> check_balance_field staker `Unstaked_finalizable Tez.zero - - let simple_roundtrip = - stake_init - --> (Tag "full unstake" --> unstake "staker" All - |+ Tag "half unstake" --> unstake "staker" Half) - --> wait_for_unfreeze_and_check default_unstake_wait - --> finalize "staker" --> next_cycle - - let double_roundtrip = - stake_init --> unstake "staker" Half - --> (Tag "half then full unstake" --> wait_n_cycles 2 - --> unstake "staker" All - |+ Tag "half then half unstake" --> wait_n_cycles 2 - --> unstake "staker" Half) - --> wait_for_unfreeze_and_check (default_unstake_wait - 2) - --> wait_for_unfreeze_and_check 2 - --> finalize "staker" --> next_cycle - - let shorter_roundtrip_for_baker = - let constants = init_constants ~autostaking_enable:false () in - let amount = Amount (Tez.of_mutez 333_000_000_000L) in - let consensus_rights_delay = constants.consensus_rights_delay in - begin_test ~activate_ai:true ~constants ["delegate"] - --> next_block --> wait_ai_activation - --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) - --> next_cycle - --> snapshot_balances "init" ["delegate"] - --> unstake "delegate" amount - --> List.fold_left - (fun acc i -> acc |+ Tag (fs "wait %i cycles" i) --> wait_n_cycles i) - (Tag "wait 0 cycles" --> Empty) - (Stdlib.List.init (consensus_rights_delay + 1) (fun i -> i + 1)) - --> stake "delegate" amount - --> check_snapshot_balances "init" - - let status_quo_rountrip = - let full_amount = Tez.of_mutez 10_000_000L in - let amount_1 = Tez.of_mutez 2_999_999L in - let amount_2 = Tez.of_mutez 7_000_001L in - snapshot_balances "init" ["staker"] - --> stake "staker" (Amount full_amount) - --> next_cycle - --> (Tag "1 unstake" --> unstake "staker" (Amount full_amount) - |+ Tag "2 unstakes" - --> unstake "staker" (Amount amount_1) - --> next_cycle - --> unstake "staker" (Amount amount_2)) - --> wait_n_cycles default_unstake_wait - --> finalize "staker" - --> check_snapshot_balances "init" - - let scenario_finalize = - no_tag --> stake "staker" Half --> next_cycle --> unstake "staker" Half - --> wait_n_cycles (default_unstake_wait + 2) - --> assert_failure - (check_balance_field "staker" `Unstaked_finalizable Tez.zero) - --> (Tag "finalize with finalize" --> finalize_unstake "staker" - |+ Tag "finalize with stake" --> stake "staker" (Amount Tez.one_mutez) - |+ Tag "finalize with unstake" - --> unstake "staker" (Amount Tez.one_mutez)) - --> check_balance_field "staker" `Unstaked_finalizable Tez.zero - - (* Finalize does not go through when unstake does nothing *) - (* Todo: there might be other cases... like changing delegates *) - let scenario_not_finalize = - no_tag --> stake "staker" Half --> next_cycle --> unstake "staker" All - --> wait_n_cycles (default_unstake_wait + 2) - --> assert_failure - (check_balance_field "staker" `Unstaked_finalizable Tez.zero) - --> snapshot_balances "not finalize" ["staker"] - --> (Tag "no finalize with unstake if staked = 0" - --> unstake "staker" (Amount Tez.one_mutez)) - --> assert_failure - (check_balance_field "staker" `Unstaked_finalizable Tez.zero) - --> check_snapshot_balances "not finalize" - - (* TODO: there's probably more... *) - let scenario_forbidden_operations = - let open Lwt_result_syntax in - let fail_if_staker_is_self_delegate staker = - exec (fun ((_, state) as input) -> - if State.(is_self_delegate staker state) then - failwith "_self_delegate_exit_" - else return input) - in - no_tag - (* Staking everything works for self delegates, but not for delegated accounts *) - --> assert_failure - (fail_if_staker_is_self_delegate "staker" --> stake "staker" All) - (* stake is always forbidden when amount is zero *) - --> assert_failure (stake "staker" Nothing) - (* One cannot stake more that one has *) - --> assert_failure (stake "staker" Max_tez) - (* unstake is actually authorized for amount 0, but does nothing (doesn't even finalize if possible) *) - --> unstake "staker" Nothing - - let full_balance_in_finalizable = - add_account_with_funds "dummy" "staker" (Amount (Tez.of_mutez 10_000_000L)) - --> stake "staker" All_but_one --> next_cycle --> unstake "staker" All - --> wait_n_cycles (default_unstake_wait + 2) - (* At this point, almost all the balance (but one mutez) of the stake is in finalizable *) - (* Staking is possible, but not transfer *) - --> assert_failure - (transfer "staker" "dummy" (Amount (Tez.of_mutez 10_000_000L))) - --> stake "staker" (Amount (Tez.of_mutez 10_000_000L)) - (* After the stake, transfer is possible again because the funds were finalized *) - --> transfer "staker" "dummy" (Amount (Tez.of_mutez 10_000_000L)) - - (* Stress test: what happens if someone were to stake and unstake every cycle? *) - let odd_behavior = - let one_cycle = - no_tag --> stake "staker" Half --> unstake "staker" Half --> next_cycle - in - loop 20 one_cycle - - let change_delegate = - let constants = init_constants ~autostaking_enable:false () in - let init_params = - { - limit_of_staking_over_baking = Q.one; - edge_of_baking_over_staking = Q.one; - } - in - begin_test ~activate_ai:true ~constants ["delegate1"; "delegate2"] - --> set_delegate_params "delegate1" init_params - --> set_delegate_params "delegate2" init_params - --> add_account_with_funds - "staker" - "delegate1" - (Amount (Tez.of_mutez 2_000_000_000_000L)) - --> set_delegate "staker" (Some "delegate1") - --> wait_ai_activation --> next_cycle --> stake "staker" Half --> next_cycle - --> set_delegate "staker" (Some "delegate2") - --> next_cycle - --> assert_failure (stake "staker" Half) - --> wait_n_cycles (default_unstake_wait + 1) - --> stake "staker" Half - - let unset_delegate = - let constants = init_constants ~autostaking_enable:false () in - let init_params = - { - limit_of_staking_over_baking = Q.one; - edge_of_baking_over_staking = Q.one; - } - in - begin_test ~activate_ai:true ~constants ["delegate"] - --> set_delegate_params "delegate" init_params - --> add_account_with_funds - "staker" - "delegate" - (Amount (Tez.of_mutez 2_000_000_000_000L)) - --> add_account_with_funds - "dummy" - "delegate" - (Amount (Tez.of_mutez 2_000_000L)) - --> set_delegate "staker" (Some "delegate") - --> wait_ai_activation --> next_cycle --> stake "staker" Half - --> unstake "staker" All --> next_cycle --> set_delegate "staker" None - --> next_cycle - --> transfer "staker" "dummy" All - (* staker has an empty liquid balance, but still has unstaked frozen tokens, - so it doesn't get deactivated *) - --> wait_n_cycles (default_unstake_wait + 1) - --> finalize_unstake "staker" - - let forbid_costaking = - let default_constants = - ("default protocol constants", init_constants ~autostaking_enable:false ()) - in - let small_delegate_parameter_constants = - ( "small delegate parameters delay", - init_constants - ~delegate_parameters_activation_delay:0 - ~autostaking_enable:false - () ) - in - let large_delegate_parameter_constants = - ( "large delegate parameters delay", - init_constants - ~delegate_parameters_activation_delay:10 - ~autostaking_enable:false - () ) - in - let init_params = - { - limit_of_staking_over_baking = Q.one; - edge_of_baking_over_staking = Q.one; - } - in - let no_costake_params = - { - limit_of_staking_over_baking = Q.zero; - edge_of_baking_over_staking = Q.one; - } - in - let amount = Amount (Tez.of_mutez 1_000_000L) in - (* init *) - begin_test - ~activate_ai:true - ~constants_list: - [ - default_constants; - small_delegate_parameter_constants; - large_delegate_parameter_constants; - ] - ["delegate"] - --> set_delegate_params "delegate" init_params - --> add_account_with_funds - "staker" - "delegate" - (Amount (Tez.of_mutez 2_000_000_000_000L)) - --> set_delegate "staker" (Some "delegate") - --> wait_cycle (`And (`AI_activation, `delegate_parameters_activation)) - --> next_cycle - (* try stake in normal conditions *) - --> stake "staker" amount - (* Change delegate parameters to forbid staking *) - --> set_delegate_params "delegate" no_costake_params - (* The changes are not immediate *) - --> stake "staker" amount - (* The parameters change is applied exactly - [delegate_parameters_activation_delay] after the request *) - --> wait_delegate_parameters_activation - (* Not yet... *) - --> stake "staker" amount - --> next_cycle - (* External staking is now forbidden *) - --> assert_failure (stake "staker" amount) - (* Can still self-stake *) - --> stake "delegate" amount - (* Can still unstake *) - --> unstake "staker" Half - --> wait_n_cycles (default_unstake_wait + 1) - --> finalize_unstake "staker" - (* Can authorize stake again *) - --> set_delegate_params "delegate" init_params - --> wait_delegate_parameters_activation - (* Not yet... *) - --> assert_failure (stake "staker" amount) - --> next_cycle - (* Now possible *) - --> stake "staker" amount - - let tests = - tests_of_scenarios - @@ [ - ("Test simple roundtrip", init_scenario () --> simple_roundtrip); - ("Test double roundtrip", init_scenario () --> double_roundtrip); - ("Test preserved balance", init_scenario () --> status_quo_rountrip); - ("Test finalize", init_scenario () --> scenario_finalize); - ("Test no finalize", init_scenario () --> scenario_not_finalize); - ( "Test forbidden operations", - init_scenario () --> scenario_forbidden_operations ); - ( "Test full balance in finalizable", - init_scenario () --> full_balance_in_finalizable ); - ("Test stake unstake every cycle", init_scenario () --> odd_behavior); - ("Test change delegate", change_delegate); - ("Test unset delegate", unset_delegate); - ("Test forbid costake", forbid_costaking); - ("Test stake from unstake", shorter_roundtrip_for_baker); - ] -end - -module Rewards = struct - let test_wait_with_rewards = - let constants = - init_constants - ~reward_per_block:1_000_000_000L - ~autostaking_enable:false - () - in - begin_test ~activate_ai:true ~constants ["delegate"] - --> (Tag "block step" --> wait_n_blocks 200 - |+ Tag "cycle step" --> wait_n_cycles 20 - |+ Tag "wait AI activation" --> next_block --> wait_ai_activation - --> (Tag "block step" --> wait_n_blocks 100 - |+ Tag "cycle step" --> wait_n_cycles 10)) - - let test_ai_curve_activation_time = - let constants = - init_constants - ~reward_per_block:1_000_000_000L - ~deactivate_dynamic:true - ~autostaking_enable:false - () - in - let pc = constants.consensus_rights_delay in - begin_test ~activate_ai:true ~burn_rewards:true ~constants [""] - --> next_block --> save_current_rate (* before AI rate *) - --> wait_ai_activation - (* Rate remains unchanged right after AI activation, we must wait [pc + 1] cycles *) - --> check_rate_evolution Q.equal - --> wait_n_cycles pc - --> check_rate_evolution Q.equal - --> next_cycle - (* The new rate should be active now. With the chosen constants, it should be lower. - We go from 1000tz per day to (at most) 5% of 4_000_000tz per year *) - --> check_rate_evolution Q.gt - - let test_static = - let constants = - init_constants - ~reward_per_block:1_000_000_000L - ~deactivate_dynamic:true - ~autostaking_enable:false - () - in - let rate_var_lag = constants.consensus_rights_delay in - let init_params = - { - limit_of_staking_over_baking = Q.one; - edge_of_baking_over_staking = Q.one; - } - in - let delta = Amount (Tez.of_mutez 20_000_000_000L) in - let cycle_stake = - save_current_rate --> stake "delegate" delta --> next_cycle - --> check_rate_evolution Q.gt - in - let cycle_unstake = - save_current_rate --> unstake "delegate" delta --> next_cycle - --> check_rate_evolution Q.lt - in - let cycle_stable = - save_current_rate --> next_cycle --> check_rate_evolution Q.equal - in - begin_test ~activate_ai:true ~burn_rewards:true ~constants ["delegate"] - --> set_delegate_params "delegate" init_params - --> save_current_rate --> wait_ai_activation - (* We stake about 50% of the total supply *) - --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) - --> stake "__bootstrap__" (Amount (Tez.of_mutez 1_800_000_000_000L)) - --> (Tag "increase stake, decrease rate" --> next_cycle - --> loop rate_var_lag (stake "delegate" delta --> next_cycle) - --> loop 10 cycle_stake - |+ Tag "decrease stake, increase rate" --> next_cycle - --> loop rate_var_lag (unstake "delegate" delta --> next_cycle) - --> loop 10 cycle_unstake - |+ Tag "stable stake, stable rate" --> next_cycle - --> wait_n_cycles rate_var_lag --> loop 10 cycle_stable - |+ Tag "test timing" --> wait_n_cycles rate_var_lag - --> check_rate_evolution Q.equal - --> next_cycle --> check_rate_evolution Q.gt --> save_current_rate - --> (Tag "increase stake" --> stake "delegate" delta - --> wait_n_cycles rate_var_lag - --> check_rate_evolution Q.equal - --> next_cycle --> check_rate_evolution Q.gt - |+ Tag "decrease stake" --> unstake "delegate" delta - --> wait_n_cycles rate_var_lag - --> check_rate_evolution Q.equal - --> next_cycle --> check_rate_evolution Q.lt)) - - let tests = - tests_of_scenarios - @@ [ - ("Test wait with rewards", test_wait_with_rewards); - ("Test ai curve activation time", test_ai_curve_activation_time); - (* ("Test static rate", test_static); *) - ] -end - -module Autostaking = struct - let assert_balance_evolution ~loc ~for_accounts ~part ~name ~old_balance - ~new_balance compare = - let open Lwt_result_syntax in - let old_b, new_b = - match part with - | `liquid -> - ( Q.of_int64 @@ Tez.to_mutez old_balance.liquid_b, - Q.of_int64 @@ Tez.to_mutez new_balance.liquid_b ) - | `staked -> (old_balance.staked_b, new_balance.staked_b) - | `unstaked_frozen -> - ( Q.of_int64 @@ Tez.to_mutez old_balance.unstaked_frozen_b, - Q.of_int64 @@ Tez.to_mutez new_balance.unstaked_frozen_b ) - | `unstaked_finalizable -> - ( Q.of_int64 @@ Tez.to_mutez old_balance.unstaked_finalizable_b, - Q.of_int64 @@ Tez.to_mutez new_balance.unstaked_finalizable_b ) - in - if List.mem ~equal:String.equal name for_accounts then - if compare new_b old_b then return_unit - else ( - Log.debug ~color:Log_module.warning_color "Balances changes failed:@." ; - Log.debug "@[Old Balance@ %a@]@." balance_pp old_balance ; - Log.debug "@[New Balance@ %a@]@." balance_pp new_balance ; - failwith "%s Unexpected stake evolution for %s" loc name) - else raise Not_found - - let delegate = "delegate" - - and delegator1 = "delegator1" - - and delegator2 = "delegator2" - - let setup ~activate_ai = - let constants = init_constants ~autostaking_enable:true () in - begin_test ~activate_ai ~constants [delegate] - --> add_account_with_funds - delegator1 - "__bootstrap__" - (Amount (Tez.of_mutez 2_000_000_000L)) - --> add_account_with_funds - delegator2 - "__bootstrap__" - (Amount (Tez.of_mutez 2_000_000_000L)) - --> next_cycle - --> (if activate_ai then wait_ai_activation else next_cycle) - --> snapshot_balances "before delegation" [delegate] - --> set_delegate delegator1 (Some delegate) - --> check_snapshot_balances "before delegation" - --> next_cycle - - let test_autostaking = - Tag "No Ai" --> setup ~activate_ai:false - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`staked - Q.gt) - "before delegation" - --> snapshot_balances "before second delegation" [delegate] - --> (Tag "increase delegation" - --> set_delegate delegator2 (Some delegate) - --> next_cycle - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`staked - Q.gt) - "before second delegation" - |+ Tag "constant delegation" - --> snapshot_balances "after stake change" [delegate] - --> wait_n_cycles 8 - --> check_snapshot_balances "after stake change" - |+ Tag "decrease delegation" - --> set_delegate delegator1 None - --> next_cycle - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`staked - Q.lt) - "before second delegation" - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`unstaked_frozen - Q.gt) - "before second delegation" - --> snapshot_balances "after unstake" [delegate] - --> next_cycle - --> check_snapshot_balances "after unstake" - --> wait_n_cycles 4 - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`unstaked_frozen - Q.lt) - "after unstake" - (* finalizable are auto-finalize immediately *) - --> check_snapshot_balances - ~f: - (assert_balance_evolution - ~loc:__LOC__ - ~for_accounts:[delegate] - ~part:`liquid - Q.lt) - "before finalisation") - |+ Tag "Yes AI" --> setup ~activate_ai:true - --> check_snapshot_balances "before delegation" - - let test_overdelegation = - (* This test assumes that all delegate accounts created in [begin_test] - begin with 4M tz, with 5% staked *) - let constants = init_constants ~autostaking_enable:true () in - begin_test - ~activate_ai:false - ~constants - ["delegate"; "faucet1"; "faucet2"; "faucet3"] - --> add_account_with_funds - "delegator_to_fund" - "delegate" - (Amount (Tez.of_mutez 3_600_000_000_000L)) - (* Delegate has 200k staked and 200k liquid *) - --> set_delegate "delegator_to_fund" (Some "delegate") - (* Delegate stake will not change at the end of cycle: same stake *) - --> next_cycle - --> check_balance_field "delegate" `Staked (Tez.of_mutez 200_000_000_000L) - --> transfer - "faucet1" - "delegator_to_fund" - (Amount (Tez.of_mutez 3_600_000_000_000L)) - (* Delegate is not overdelegated, but will need to freeze 180k *) - --> next_cycle - --> check_balance_field "delegate" `Staked (Tez.of_mutez 380_000_000_000L) - --> transfer - "faucet2" - "delegator_to_fund" - (Amount (Tez.of_mutez 3_600_000_000_000L)) - (* Delegate is now overdelegated, it will freeze 100% *) - --> next_cycle - --> check_balance_field "delegate" `Staked (Tez.of_mutez 400_000_000_000L) - --> transfer - "faucet3" - "delegator_to_fund" - (Amount (Tez.of_mutez 3_600_000_000_000L)) - (* Delegate is overmegadelegated *) - --> next_cycle - --> check_balance_field "delegate" `Staked (Tez.of_mutez 400_000_000_000L) - - let tests = - tests_of_scenarios - [ - ("Test auto-staking", test_autostaking); - ("Test auto-staking with overdelegation", test_overdelegation); - ] -end - -module Slashing = struct - let test_simple_slash = - let constants = init_constants ~autostaking_enable:false () in - let any_slash delegate = - Tag "double baking" --> double_bake delegate - |+ Tag "double attesting" - --> double_attest ~other_bakers:("bootstrap2", "bootstrap3") delegate - |+ Tag "double preattesting" - --> double_preattest - ~other_bakers:("bootstrap2", "bootstrap3") - delegate - in - begin_test - ~activate_ai:true - ~ns_enable_fork:true - ~constants - ["delegate"; "bootstrap1"; "bootstrap2"; "bootstrap3"] - --> (Tag "No AI" --> next_cycle - |+ Tag "Yes AI" --> next_block --> wait_ai_activation) - --> any_slash "delegate" - --> snapshot_balances "before slash" ["delegate"] - --> ((Tag "denounce same cycle" - --> make_denunciations () - (* delegate can be forbidden in this case, so we set another baker *) - --> exclude_bakers ["delegate"] - |+ Tag "denounce next cycle" --> next_cycle --> make_denunciations () - (* delegate can be forbidden in this case, so we set another baker *) - --> exclude_bakers ["delegate"]) - --> (Empty - |+ Tag "another slash" --> any_slash "bootstrap1" - --> make_denunciations () - (* bootstrap1 can be forbidden in this case, so we set another baker *) - --> exclude_bakers ["delegate"; "bootstrap1"]) - --> check_snapshot_balances "before slash" - --> exec_unit check_pending_slashings - --> next_cycle - --> assert_failure - (exec_unit (fun (_block, state) -> - if state.State.constants.adaptive_issuance.ns_enable then - failwith "ns_enable = true: slash not applied yet" - else Lwt_result_syntax.return_unit) - --> check_snapshot_balances "before slash") - --> exec_unit check_pending_slashings - --> next_cycle - |+ Tag "denounce too late" --> next_cycle --> next_cycle - --> assert_failure - ~expected_error:(fun (_block, state) -> - let ds = state.State.double_signings in - let ds = match ds with [a] -> a | _ -> assert false in - let level = - Protocol.Alpha_context.Raw_level.of_int32_exn - (Int32.succ ds.level) - in - let last_cycle = - Cycle.add - (Block.current_cycle_of_level - ~blocks_per_cycle: - state.State.constants.blocks_per_cycle - ~current_level:ds.level) - Protocol.Constants_repr.max_slashing_period - in - let (kind : Protocol.Alpha_context.Misbehaviour.kind) = - (* This conversion would not be needed if - Misbehaviour_repr.kind were moved to a - separate file that doesn't have under/over - Alpha_context versions. *) - match ds.kind with - | Double_baking -> Double_baking - | Double_attesting -> Double_attesting - | Double_preattesting -> Double_preattesting - in - [ - Environment.Ecoproto_error - (Protocol.Validate_errors.Anonymous.Outdated_denunciation - {kind; level; last_cycle}); - ]) - (make_denunciations ()) - --> check_snapshot_balances "before slash") - - let check_is_forbidden baker = assert_failure (next_block_with_baker baker) - - let check_is_not_forbidden baker = - let open Lwt_result_syntax in - exec (fun ((block, state) as input) -> - let baker = State.find_account baker state in - let*! _ = Block.bake ~policy:(By_account baker.pkh) block in - return input) - - let test_delegate_forbidden = - let constants = - init_constants ~blocks_per_cycle:30l ~autostaking_enable:false () - in - begin_test - ~activate_ai:false - ~ns_enable_fork:true - ~constants - ["delegate"; "bootstrap1"; "bootstrap2"] - --> set_baker "bootstrap1" - --> (Tag "Many double bakes" - --> loop_action 14 (double_bake_ "delegate") - --> (Tag "14 double bakes are not enough to forbid a delegate" - (* 7*14 = 98 *) - --> make_denunciations () - --> check_is_not_forbidden "delegate" - |+ Tag "15 double bakes is one too many" - (* 7*15 = 105 > 100 *) - --> double_bake "delegate" - --> make_denunciations () - --> check_is_forbidden "delegate") - |+ Tag "Is forbidden after first denunciation" - --> double_attest "delegate" - --> (Tag "very early first denounce" --> make_denunciations () - --> (Tag "in same cycle" --> Empty - |+ Tag "next cycle" --> next_cycle) - --> check_is_forbidden "delegate") - |+ Tag "Is unforbidden after 7 cycles" --> double_attest "delegate" - --> make_denunciations () - --> exclude_bakers ["delegate"] - --> check_is_forbidden "delegate" - --> stake "delegate" Half - --> check_is_not_forbidden "delegate" - |+ Tag - "Two double attestations, in consecutive cycles, denounce out of \ - order" --> double_attest "delegate" --> next_cycle - --> double_attest "delegate" - --> make_denunciations - ~filter:(fun {level; denounced; _} -> - (not denounced) && level > 10l) - () - --> make_denunciations - ~filter:(fun {level; denounced; _} -> - (not denounced) && level <= 10l) - () - --> check_is_forbidden "delegate") - - let test_slash_unstake = - let constants = init_constants ~autostaking_enable:false () in - begin_test - ~activate_ai:false - ~ns_enable_fork:true - ~constants - ["delegate"; "bootstrap1"; "bootstrap2"] - --> set_baker "bootstrap1" --> next_cycle --> unstake "delegate" Half - --> next_cycle --> double_bake "delegate" --> make_denunciations () - --> (Empty |+ Tag "unstake twice" --> unstake "delegate" Half) - --> wait_n_cycles 5 - --> finalize_unstake "delegate" - - let test_slash_monotonous_stake = - let scenario ~offending_op ~op ~early_d = - let constants = - init_constants ~blocks_per_cycle:16l ~autostaking_enable:false () - in - begin_test - ~activate_ai:false - ~ns_enable_fork:true - ~constants - ["delegate"; "bootstrap1"] - --> next_cycle - --> loop - 6 - (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) --> next_cycle) - --> offending_op "delegate" - --> (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) - --> loop - 2 - (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) - --> - if early_d then - make_denunciations () - --> exclude_bakers ["delegate"] - --> next_block - else offending_op "delegate" --> next_block)) - in - Tag "slashes with increasing stake" - --> (Tag "denounce early" - --> (Tag "Double Bake" - --> scenario ~offending_op:double_bake ~op:stake ~early_d:true - |+ Tag "Double attest" - --> scenario ~offending_op:double_attest ~op:stake ~early_d:true - ) - |+ Tag "denounce late" - --> (Tag "Double Bake" - --> scenario ~offending_op:double_bake ~op:stake ~early_d:false - |+ Tag "Double attest" - --> scenario - ~offending_op:double_attest - ~op:stake - ~early_d:false) - --> make_denunciations ()) - |+ Tag "slashes with decreasing stake" - --> (Tag "Double Bake" - --> scenario ~offending_op:double_bake ~op:unstake ~early_d:true - |+ Tag "Double attest" - --> scenario ~offending_op:double_attest ~op:unstake ~early_d:true - ) - |+ Tag "denounce late" - --> (Tag "Double Bake" - --> scenario ~offending_op:double_bake ~op:unstake ~early_d:false - |+ Tag "Double attest" - --> scenario - ~offending_op:double_attest - ~op:unstake - ~early_d:false) - --> make_denunciations () - - let test_slash_timing = - let constants = - init_constants ~blocks_per_cycle:8l ~autostaking_enable:false () - in - begin_test ~activate_ai:false ~ns_enable_fork:true ~constants ["delegate"] - --> next_cycle - --> (Tag "stake" --> stake "delegate" Half - |+ Tag "unstake" --> unstake "delegate" Half) - --> (Tag "with a first slash" --> double_bake "delegate" - --> make_denunciations () - |+ Tag "without another slash" --> Empty) - --> List.fold_left - (fun acc i -> - acc |+ Tag (string_of_int i ^ " cycles lag") --> wait_n_cycles i) - Empty - [3; 4; 5; 6] - --> double_bake "delegate" --> make_denunciations () --> next_cycle - - let init_scenario_with_delegators delegate_name faucet_name delegators_list = - let constants = init_constants ~autostaking_enable:false () in - let rec init_delegators = function - | [] -> Empty - | (delegator, amount) :: t -> - add_account_with_funds - delegator - faucet_name - (Amount (Tez.of_mutez amount)) - --> set_delegate delegator (Some delegate_name) - --> init_delegators t - in - let init_params = - { - limit_of_staking_over_baking = Q.one; - edge_of_baking_over_staking = Q.one; - } - in - begin_test - ~activate_ai:true - ~ns_enable_fork:true - ~constants - [delegate_name; faucet_name] - --> set_baker faucet_name - --> set_delegate_params "delegate" init_params - --> init_delegators delegators_list - --> next_block --> wait_ai_activation - - let test_many_slashes = - let rec stake_unstake_for = function - | [] -> Empty - | staker :: t -> - stake staker Half --> unstake staker Half --> stake_unstake_for t - in - let slash delegate = double_bake delegate --> make_denunciations () in - Tag "double bake" - --> (Tag "solo delegate" - --> init_scenario_with_delegators - "delegate" - "faucet" - [("delegator", 1_234_567_891L)] - --> loop - 10 - (stake_unstake_for ["delegate"] - --> slash "delegate" --> next_cycle)) - (* |+ Tag "delegate with one staker" - --> init_scenario_with_delegators - "delegate" - "faucet" - [("staker", 1_234_356_891L)] - --> loop - 10 - (stake_unstake_for ["delegate"; "staker"] - --> slash "delegate" --> next_cycle) - |+ Tag "delegate with three stakers" - --> init_scenario_with_delegators - "delegate" - "faucet" - [ - ("staker1", 1_234_356_891L); - ("staker2", 1_234_356_890L); - ("staker3", 1_723_333_111L); - ] - --> loop - 10 - (stake_unstake_for - ["delegate"; "staker1"; "staker2"; "staker3"] - --> slash "delegate" --> next_cycle))*) - - let test_no_shortcut_for_cheaters = - let constants = init_constants ~autostaking_enable:false () in - let amount = Amount (Tez.of_mutez 333_000_000_000L) in - let consensus_rights_delay = constants.consensus_rights_delay in - begin_test - ~activate_ai:true - ~ns_enable_fork:false - ~constants - ["delegate"; "bootstrap1"] - --> next_block --> wait_ai_activation - --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) - --> next_cycle --> double_bake "delegate" --> make_denunciations () - --> set_baker "bootstrap1" (* exclude_bakers ["delegate"] *) - --> next_cycle - --> snapshot_balances "init" ["delegate"] - --> unstake "delegate" amount - --> (List.fold_left - (fun acc i -> acc |+ Tag (fs "wait %i cycles" i) --> wait_n_cycles i) - (Tag "wait 0 cycles" --> Empty) - (Stdlib.List.init (consensus_rights_delay - 1) (fun i -> i + 1)) - --> stake "delegate" amount - --> assert_failure (check_snapshot_balances "init") - |+ Tag "wait enough cycles (consensus_rights_delay + 1)" - --> wait_n_cycles (consensus_rights_delay + 1) - --> stake "delegate" amount - --> check_snapshot_balances "init") - - let test_slash_correct_amount_after_stake_from_unstake = - let constants = init_constants ~autostaking_enable:false () in - let amount_to_unstake = Amount (Tez.of_mutez 200_000_000_000L) in - let amount_to_restake = Amount (Tez.of_mutez 100_000_000_000L) in - let amount_expected_in_unstake_after_slash = Tez.of_mutez 50_000_000_000L in - let consensus_rights_delay = constants.consensus_rights_delay in - begin_test - ~activate_ai:true - ~ns_enable_fork:false - ~constants - ["delegate"; "bootstrap1"] - --> next_block --> wait_ai_activation - --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) - --> next_cycle - --> unstake "delegate" amount_to_unstake - --> stake "delegate" amount_to_restake - --> List.fold_left - (fun acc i -> acc |+ Tag (fs "wait %i cycles" i) --> wait_n_cycles i) - (Tag "wait 0 cycles" --> Empty) - (Stdlib.List.init (consensus_rights_delay - 2) (fun i -> i + 1)) - --> double_attest "delegate" --> make_denunciations () - --> exclude_bakers ["delegate"] - --> next_cycle - --> check_balance_field - "delegate" - `Unstaked_frozen_total - amount_expected_in_unstake_after_slash - - (* Test a non-zero request finalizes for a non-zero amount if it hasn't been slashed 100% *) - let test_mini_slash = - let constants = init_constants ~autostaking_enable:false () in - (Tag "Yes AI" - --> begin_test - ~activate_ai:true - ~ns_enable_fork:false - ~constants - ["delegate"; "baker"] - --> next_block --> wait_ai_activation - |+ Tag "No AI" - --> begin_test - ~activate_ai:false - ~ns_enable_fork:false - ~constants - ["delegate"; "baker"]) - --> unstake "delegate" (Amount Tez.one_mutez) - --> set_baker "baker" --> next_cycle - --> (Tag "5% slash" --> double_bake "delegate" --> make_denunciations () - |+ Tag "95% slash" --> next_cycle --> double_attest "delegate" - --> loop 9 (double_bake "delegate") - --> make_denunciations ()) - (* Wait two cycles because of ns_enable *) - --> next_cycle - --> next_cycle - --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero - --> wait_n_cycles (constants.consensus_rights_delay + 1) - - let test_slash_rounding = - let constants = init_constants ~autostaking_enable:false () in - begin_test - ~activate_ai:true - ~ns_enable_fork:true - ~constants - ["delegate"; "baker"] - --> set_baker "baker" --> next_block --> wait_ai_activation - --> unstake "delegate" (Amount (Tez.of_mutez 2L)) - --> next_cycle --> double_bake "delegate" --> double_bake "delegate" - --> make_denunciations () --> wait_n_cycles 7 - --> finalize_unstake "delegate" - - (* TODO #6645: reactivate tests *) - let tests = - tests_of_scenarios - @@ [ - ("Test simple slashing", test_simple_slash); - ("Test slashed is forbidden", test_delegate_forbidden); - ("Test slash with unstake", test_slash_unstake); - (* TODO: make sure this test passes with blocks_per_cycle:8l - https://gitlab.com/tezos/tezos/-/issues/6904 *) - ("Test slashes with simple varying stake", test_slash_monotonous_stake); - (* This test has been deactivated following the changes of the - forbidding mechanism that now forbids delegates right after the - first denunciation, it should be fixed and reactivated - https://gitlab.com/tezos/tezos/-/issues/6904 *) - (* ( "Test multiple slashes with multiple stakes/unstakes", *) - (* test_many_slashes ); *) - (* ("Test slash timing", test_slash_timing); *) - ( "Test stake from unstake deactivated when slashed", - test_no_shortcut_for_cheaters ); - ( "Test stake from unstake reduce initial amount", - test_slash_correct_amount_after_stake_from_unstake ); - ("Test unstake 1 mutez then slash", test_mini_slash); - ("Test slash rounding", test_slash_rounding); - ] -end - -let tests = - let open Lwt_result_syntax in - (tests_of_scenarios - @@ [ - ("Test expected error in assert failure", test_expected_error); - ("Test init", init_scenario () --> Action (fun _ -> return_unit)); - ]) - @ Roundtrip.tests @ Rewards.tests @ Autostaking.tests @ Slashing.tests - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("adaptive issuance roundtrip", tests)] - |> Lwt_main.run diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_constants.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_constants.ml index ee7a4a4792e5212ef5a7cbfc83e53110160b2de0..0c03f3a90d3ada1ab515b4235f71a4b45b91cf45 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_constants.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_constants.ml @@ -32,9 +32,13 @@ Subject: the consistency of parametric constants *) -open Test_tez +open Tez_helpers -let test_sc_rollup_constants_consistency () = +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["constants"] + +let () = + register_test ~title:"sc_rollup constants consistency" @@ fun () -> let open Protocol.Alpha_context in let to_string c = Data_encoding.Json.( @@ -63,13 +67,15 @@ let test_sc_rollup_constants_consistency () = sc_rollup sc_rollup' -let test_constants_consistency () = +let () = + register_test ~title:"constants consistency" @@ fun () -> let open Default_parameters in List.iter_es Block.check_constants_consistency [constants_mainnet; constants_sandbox; constants_test] -let test_max_operations_ttl () = +let () = + register_test ~title:"max_operations_ttl" @@ fun () -> let open Lwt_result_wrap_syntax in let open Protocol in (* We check the rationale that the value for [max_operations_time_to_live] is the following: @@ -94,7 +100,9 @@ let test_max_operations_ttl () = Otherwise committers would be forced to commit at an artificially slow rate, affecting the throughput of the rollup. *) -let test_sc_rollup_challenge_window_lt_max_lookahead () = +let () = + register_test ~title:"sc rollup challenge window less than max lookahead" + @@ fun () -> let constants = Default_parameters.constants_mainnet in let max_lookahead = constants.sc_rollup.max_lookahead_in_blocks in let challenge_window = @@ -111,7 +119,9 @@ let test_sc_rollup_challenge_window_lt_max_lookahead () = Otherwise storage could be overallocated - since backtracking is not allowed, a staker can allocated at most [d] nodes (where [d] is the tree depth) - the maximum storage cost of these commitments must be at most the size of the staker's deposit. *) -let test_sc_rollup_max_commitment_storage_cost_lt_deposit () = +let () = + register_test ~title:"sc rollup max commitment storage cost less than deposit" + @@ fun () -> let constants = Default_parameters.constants_mainnet in let open Protocol in let cost_per_byte_mutez = @@ -150,7 +160,8 @@ let test_sc_rollup_max_commitment_storage_cost_lt_deposit () = correctly scaled with respect to each other - see {!test_sc_rollup_max_commitment_storage_cost_lt_deposit} *) -let test_sc_rollup_max_commitment_storage_size () = +let () = + register_test ~title:"sc rollup commitment storage size correct" @@ fun () -> let open Lwt_result_syntax in let open Protocol in let* number_of_ticks = @@ -208,7 +219,11 @@ let test_sc_rollup_max_commitment_storage_size () = (** Test that the amount of the liquidity baking subsidy is epsilon smaller than 1/16th of the maximum reward. *) -let liquidity_baking_subsidy_param () = +let () = + register_test + ~title: + "liquidity_baking_subsidy parameter is 1/16th of total baking rewards" + @@ fun () -> let open Lwt_result_wrap_syntax in let constants = Default_parameters.constants_mainnet in let get_reward = @@ -242,34 +257,3 @@ let liquidity_baking_subsidy_param () = let*? diff = liquidity_baking_subsidy -? expected_subsidy in let max_diff = 1000 (* mutez *) in Assert.leq_int ~loc:__LOC__ (Int64.to_int (to_mutez diff)) max_diff - -let tests = - [ - Tztest.tztest - "sc_rollup constants consistency" - `Quick - test_sc_rollup_constants_consistency; - Tztest.tztest "constants consistency" `Quick test_constants_consistency; - Tztest.tztest "max_operations_ttl" `Quick test_max_operations_ttl; - Tztest.tztest - "sc rollup challenge window less than max lookahead" - `Quick - test_sc_rollup_challenge_window_lt_max_lookahead; - Tztest.tztest - "sc rollup max commitment storage cost less than deposit" - `Quick - test_sc_rollup_max_commitment_storage_cost_lt_deposit; - Tztest.tztest - "sc rollup commitment storage size correct" - `Quick - test_sc_rollup_max_commitment_storage_size; - Tztest.tztest - "test liquidity_baking_subsidy parameter is 1/16th of total baking \ - rewards" - `Quick - liquidity_baking_subsidy_param; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("test constants", tests)] - |> Lwt_main.run diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_frozen_bonds.ml index dc235af2c07eac3a79b75e38da6f2e8d4da30d5e..c44d8e7f68e6017641229dec298403066b9be721 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_frozen_bonds.ml @@ -15,7 +15,10 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers + +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["frozen_bonds"] let big_random_amount () = match Tez.of_mutez (Int64.add 100_000L (Random.int64 1_000_000L)) with @@ -708,61 +711,38 @@ let test_delegate_freeze_slash_undelegate () = in return_unit) -let tests = - Tztest. - [ - tztest - "frozen bonds - delegate then freeze" - `Quick - test_delegate_then_freeze_deposit; - tztest - "frozen bonds - freeze then delegate" - `Quick - test_freeze_deposit_then_delegate; - tztest - "frozen bonds - contract remains allocated, user is not a delegate" - `Quick - (test_allocated_when_frozen_deposits_exists ~user_is_delegate:false); - tztest - "frozen bonds - contract remains allocated, user is a delegate" - `Quick - (test_allocated_when_frozen_deposits_exists ~user_is_delegate:true); - tztest - "frozen bonds - total stake, user is not a delegate" - `Quick - (test_total_stake ~user_is_delegate:false); - tztest - "frozen bonds - total stake, user is a delegate" - `Quick - (test_total_stake ~user_is_delegate:true); - tztest "frozen bonds - delegated balance" `Quick test_delegated_balance; - tztest "frozen bonds - test rpcs" `Quick test_rpcs; - tztest - "delegate, freeze, unfreeze, undelegate" - `Quick - test_delegate_freeze_unfreeze_undelegate; - tztest - "delegate, freeze, undelegate, unfreeze" - `Quick - test_delegate_freeze_undelegate_unfreeze; - tztest - "delegate, double freeze, undelegate, unfreeze" - `Quick - test_delegate_double_freeze_undelegate_unfreeze; - tztest - "delegate, freeze, redelegate, unfreeze" - `Quick - test_delegate_freeze_redelegate_unfreeze; - tztest - "delegate, freeze, unfreeze, freeze, redelegate" - `Quick - test_delegate_freeze_unfreeze_freeze_redelegate; - tztest - "delegate, freeze, slash, undelegate" - `Quick - test_delegate_freeze_slash_undelegate; - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("frozen bonds", tests)] - |> Lwt_main.run + register_test ~title:"delegate then freeze" test_delegate_then_freeze_deposit ; + register_test ~title:"freeze then delegate" test_freeze_deposit_then_delegate ; + register_test + ~title:"contract remains allocated, user is not a delegate" + (test_allocated_when_frozen_deposits_exists ~user_is_delegate:false) ; + register_test + ~title:"contract remains allocated, user is a delegate" + (test_allocated_when_frozen_deposits_exists ~user_is_delegate:true) ; + register_test + ~title:"total stake, user is not a delegate" + (test_total_stake ~user_is_delegate:false) ; + register_test + ~title:"total stake, user is a delegate" + (test_total_stake ~user_is_delegate:true) ; + register_test ~title:"delegated balance" test_delegated_balance ; + register_test ~title:"test rpcs" test_rpcs ; + register_test + ~title:"delegate, freeze, unfreeze, undelegate" + test_delegate_freeze_unfreeze_undelegate ; + register_test + ~title:"delegate, freeze, undelegate, unfreeze" + test_delegate_freeze_undelegate_unfreeze ; + register_test + ~title:"delegate, double freeze, undelegate, unfreeze" + test_delegate_double_freeze_undelegate_unfreeze ; + register_test + ~title:"delegate, freeze, redelegate, unfreeze" + test_delegate_freeze_redelegate_unfreeze ; + register_test + ~title:"delegate, freeze, unfreeze, freeze, redelegate" + test_delegate_freeze_unfreeze_freeze_redelegate ; + register_test + ~title:"delegate, freeze, slash, undelegate" + test_delegate_freeze_slash_undelegate diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_liquidity_baking.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_liquidity_baking.ml index 6935e2dc190ccf1259e5eda9ba19ad246bc35188..0cd3ab6a6f3ed5e67250161184a3450e550e478a 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_liquidity_baking.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_liquidity_baking.ml @@ -34,7 +34,10 @@ open Liquidity_baking_machine open Protocol -open Test_tez +open Tez_helpers + +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["liquidity_baking"] let generate_init_state () = let open Lwt_result_syntax in @@ -467,7 +470,7 @@ let liquidity_baking_origination_result_cpmm_balance () = in let result = get_cpmm_result origination_results in let balance_update = get_balance_update_in_result result in - let* () = Assert.equal_tez ~loc:__LOC__ balance_update (of_mutez_exn 100L) in + let* () = Assert.equal_tez ~loc:__LOC__ balance_update (of_mutez 100L) in return_unit let liquidity_baking_origination_result_lqt_address () = @@ -508,8 +511,8 @@ let liquidity_baking_origination_result_lqt_balance () = ] -> let* () = Assert.equal_tez ~loc:__LOC__ am1 am2 in let* () = Assert.equal_tez ~loc:__LOC__ am3 am4 in - let* () = Assert.equal_tez ~loc:__LOC__ am1 (of_mutez_exn 64_250L) in - Assert.equal_tez ~loc:__LOC__ am3 (of_mutez_exn 494_500L) + let* () = Assert.equal_tez ~loc:__LOC__ am1 (of_mutez 64_250L) in + Assert.equal_tez ~loc:__LOC__ am3 (of_mutez 494_500L) | _ -> failwith "Unexpected balance updates (%s)" __LOC__ (* Test that with no contract at the tzBTC address and the level low enough to indicate we're not on mainnet, three contracts are originated in stitching. *) @@ -535,123 +538,97 @@ let liquidity_baking_origination_no_tzBTC_mainnet_migration () = let num_results = List.length origination_results in Assert.equal_int ~loc:__LOC__ num_results 0 -let tests = - [ - Tztest.tztest - "liquidity baking script hashes" - `Quick - liquidity_baking_origination; - Tztest.tztest - "liquidity baking cpmm is originated at the expected address" - `Quick - liquidity_baking_cpmm_address; - Tztest.tztest "Init Context" `Quick generate_init_state; - Tztest.tztest - "liquidity baking subsidy is correct" - `Quick - (liquidity_baking_subsidies 64); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting \ - Per_block_vote_off baking one block longer" - `Quick - (liquidity_baking_toggle_100 1); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting \ - Per_block_vote_off baking two blocks longer" - `Quick - (liquidity_baking_toggle_100 2); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting \ - Per_block_vote_off baking 100 blocks longer" - `Quick - (liquidity_baking_toggle_100 100); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting \ - Per_block_vote_off baking one block longer" - `Quick - (liquidity_baking_toggle_80 1); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting \ - Per_block_vote_off baking two blocks longer" - `Quick - (liquidity_baking_toggle_80 2); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting \ - Per_block_vote_off baking 100 blocks longer" - `Quick - (liquidity_baking_toggle_80 100); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting \ - Per_block_vote_off baking one block longer" - `Quick - (liquidity_baking_toggle_60 1); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting \ - Per_block_vote_off baking two blocks longer" - `Quick - (liquidity_baking_toggle_60 2); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting \ - Per_block_vote_off baking 100 blocks longer" - `Quick - (liquidity_baking_toggle_60 100); - Tztest.tztest - "liquidity baking does not shut off with toggle vote at 50% and baking \ - 100 blocks longer than sunset level in previous protocols" - `Quick - liquidity_baking_toggle_50; - Tztest.tztest - "liquidity baking restart with 100% of bakers voting off, then pass, \ - then on" - `Quick - (liquidity_baking_restart 2000 1); - Tztest.tztest - "liquidity baking toggle ema in block metadata is zero with no bakers \ - voting Per_block_vote_off." - `Quick - liquidity_baking_toggle_ema_zero; - Tztest.tztest - "liquidity baking toggle ema is equal to the threshold after the subsidy \ - has been stopped by a toggle vote" - `Quick - liquidity_baking_toggle_ema_threshold; - Tztest.tztest - "liquidity baking storage is updated" - `Quick - (liquidity_baking_storage 64); - Tztest.tztest - "liquidity baking balance updates" - `Quick - liquidity_baking_balance_update; - Tztest.tztest - "liquidity baking CPMM address in storage matches address in the \ - origination result" - `Quick - liquidity_baking_origination_result_cpmm_address; - Tztest.tztest - "liquidity baking CPMM balance in origination result is 100 mutez" - `Quick - liquidity_baking_origination_result_cpmm_balance; - Tztest.tztest - "liquidity baking LQT contract is originated at expected address" - `Quick - liquidity_baking_origination_result_lqt_address; - Tztest.tztest - "liquidity baking LQT balance in origination result is 0 mutez" - `Quick - liquidity_baking_origination_result_lqt_balance; - Tztest.tztest - "liquidity baking originates three contracts when tzBTC does not exist \ - and level indicates we are not on mainnet" - `Quick - liquidity_baking_origination_test_migration; - Tztest.tztest - "liquidity baking originates three contracts when tzBTC does not exist \ - and level indicates we might be on mainnet" - `Quick - liquidity_baking_origination_no_tzBTC_mainnet_migration; - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("liquidity baking", tests)] - |> Lwt_main.run + register_test ~title:"script hashes" liquidity_baking_origination ; + register_test + ~title:"cpmm is originated at the expected address" + liquidity_baking_cpmm_address ; + register_test ~title:"Init Context" generate_init_state ; + register_test ~title:"subsidy is correct" (liquidity_baking_subsidies 64) ; + register_test + ~title: + "toggle vote with 100% of bakers voting Per_block_vote_off baking one \ + block longer" + (liquidity_baking_toggle_100 1) ; + register_test + ~title: + "toggle vote with 100% of bakers voting Per_block_vote_off baking two \ + blocks longer" + (liquidity_baking_toggle_100 2) ; + register_test + ~title: + "toggle vote with 100% of bakers voting Per_block_vote_off baking 100 \ + blocks longer" + (liquidity_baking_toggle_100 100) ; + register_test + ~title: + "toggle vote with 80% of bakers voting Per_block_vote_off baking one \ + block longer" + (liquidity_baking_toggle_80 1) ; + register_test + ~title: + "toggle vote with 80% of bakers voting Per_block_vote_off baking two \ + blocks longer" + (liquidity_baking_toggle_80 2) ; + register_test + ~title: + "toggle vote with 80% of bakers voting Per_block_vote_off baking 100 \ + blocks longer" + (liquidity_baking_toggle_80 100) ; + register_test + ~title: + "toggle vote with 60% of bakers voting Per_block_vote_off baking one \ + block longer" + (liquidity_baking_toggle_60 1) ; + register_test + ~title: + "toggle vote with 60% of bakers voting Per_block_vote_off baking two \ + blocks longer" + (liquidity_baking_toggle_60 2) ; + register_test + ~title: + "toggle vote with 60% of bakers voting Per_block_vote_off baking 100 \ + blocks longer" + (liquidity_baking_toggle_60 100) ; + register_test + ~title: + "does not shut off with toggle vote at 50% and baking 100 blocks longer \ + than sunset level in previous protocols" + liquidity_baking_toggle_50 ; + register_test + ~title:"restart with 100% of bakers voting off, then pass, then on" + (liquidity_baking_restart 2000 1) ; + register_test + ~title: + "toggle ema in block metadata is zero with no bakers voting \ + Per_block_vote_off." + liquidity_baking_toggle_ema_zero ; + register_test + ~title: + "toggle ema is equal to the threshold after the subsidy has been stopped \ + by a toggle vote" + liquidity_baking_toggle_ema_threshold ; + register_test ~title:"storage is updated" (liquidity_baking_storage 64) ; + register_test ~title:"balance updates" liquidity_baking_balance_update ; + register_test + ~title:"CPMM address in storage matches address in the origination result" + liquidity_baking_origination_result_cpmm_address ; + register_test + ~title:"CPMM balance in origination result is 100 mutez" + liquidity_baking_origination_result_cpmm_balance ; + register_test + ~title:"LQT contract is originated at expected address" + liquidity_baking_origination_result_lqt_address ; + register_test + ~title:"LQT balance in origination result is 0 mutez" + liquidity_baking_origination_result_lqt_balance ; + register_test + ~title: + "originates three contracts when tzBTC does not exist and level \ + indicates we are not on mainnet" + liquidity_baking_origination_test_migration ; + register_test + ~title: + "originates three contracts when tzBTC does not exist and level \ + indicates we might be on mainnet" + liquidity_baking_origination_no_tzBTC_mainnet_migration diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_autostaking.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_autostaking.ml new file mode 100644 index 0000000000000000000000000000000000000000..734babdeb1d38eed4c84bc46f2016a23f74a17b5 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_autostaking.ml @@ -0,0 +1,254 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Adaptive Issuance, Autostaking + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_autostaking.ml + Subject: Test autostaking in the protocol. +*) + +open State_account +open Tez_helpers.Ez_tez +open Scenario +open Log_helpers + +let assert_balance_evolution ~loc ~for_accounts ~part ~name ~old_balance + ~new_balance compare = + let open Lwt_result_syntax in + let old_b, new_b = + match part with + | `liquid -> + ( Q.of_int64 @@ Tez.to_mutez old_balance.liquid_b, + Q.of_int64 @@ Tez.to_mutez new_balance.liquid_b ) + | `staked -> (old_balance.staked_b, new_balance.staked_b) + | `unstaked_frozen -> + ( Q.of_int64 @@ Tez.to_mutez old_balance.unstaked_frozen_b, + Q.of_int64 @@ Tez.to_mutez new_balance.unstaked_frozen_b ) + | `unstaked_finalizable -> + ( Q.of_int64 @@ Tez.to_mutez old_balance.unstaked_finalizable_b, + Q.of_int64 @@ Tez.to_mutez new_balance.unstaked_finalizable_b ) + in + if List.mem ~equal:String.equal name for_accounts then + if compare new_b old_b then return_unit + else ( + Log.debug ~color:warning_color "Balances changes failed:@." ; + Log.debug "@[Old Balance@ %a@]@." balance_pp old_balance ; + Log.debug "@[New Balance@ %a@]@." balance_pp new_balance ; + Log.debug + "@[Diff between balances@ %a@]@." + Q.pp_print + Q.(new_b - old_b) ; + failwith "%s Unexpected stake evolution for %s" loc name) + else ( + Log.error + "Test_scenario_autostaking.assert_balance_evolution: account %s not found" + name ; + assert false) + +let gt_diff diff new_b old_b = + let diff = Q.of_int64 @@ Tez.to_mutez diff in + Q.equal new_b (Q.add old_b diff) + +let lt_diff diff new_b old_b = + let diff = Q.of_int64 @@ Tez.to_mutez diff in + Q.equal new_b (Q.sub old_b diff) + +let delegate = "delegate" + +and delegator1 = "delegator1" + +and delegator2 = "delegator2" + +let setup ~activate_ai = + init_constants () + --> set S.Adaptive_issuance.autostaking_enable true + --> Scenario_begin.activate_ai (if activate_ai then `Force else `No) + --> begin_test [delegate] + --> add_account_with_funds + delegator1 + ~funder:"__bootstrap__" + (Amount (Tez.of_mutez 2_000_000_000L)) + --> add_account_with_funds + delegator2 + ~funder:"__bootstrap__" + (Amount (Tez.of_mutez 2_000_000_000L)) + --> next_cycle + --> snapshot_balances "before delegation" [delegate] + --> set_delegate delegator1 (Some delegate) + --> check_snapshot_balances "before delegation" + --> next_cycle + +let test_autostaking = + Tag "No Ai" --> setup ~activate_ai:false + (* Delegate will need to freeze 5% * 2k = 100 *) + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`staked + (gt_diff @@ Tez.of_mutez 100_000_000L)) + "before delegation" + --> snapshot_balances "before second delegation" [delegate] + --> (Tag "increase delegation" + --> set_delegate delegator2 (Some delegate) + --> next_cycle + (* Delegate will need to freeze 5% * 2k = 100 *) + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`staked + (gt_diff @@ Tez.of_mutez 100_000_000L)) + "before second delegation" + |+ Tag "constant delegation" + --> snapshot_balances "after stake change" [delegate] + --> wait_n_cycles 6 + --> check_snapshot_balances "after stake change" + |+ Tag "decrease delegation" + --> set_delegate delegator1 None + --> next_cycle + (* Delegate will need to unfreeze 5% * 2k = 100 *) + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`staked + (lt_diff @@ Tez.of_mutez 100_000_000L)) + "before second delegation" + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`unstaked_frozen + (gt_diff @@ Tez.of_mutez 100_000_000L)) + "before second delegation" + --> snapshot_balances "after unstake" [delegate] + --> next_cycle + --> check_snapshot_balances "after unstake" + --> wait_n_cycles_f Test_scenario_stake.(unstake_wait -- 1) + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`unstaked_frozen + (lt_diff @@ Tez.of_mutez 100_000_000L)) + "after unstake" + (* finalizable are auto-finalize immediately *) + --> check_snapshot_balances + ~f: + (assert_balance_evolution + ~loc:__LOC__ + ~for_accounts:[delegate] + ~part:`liquid + (gt_diff @@ Tez.of_mutez 100_000_000L)) + "after unstake") + |+ Tag "Yes AI" --> setup ~activate_ai:true + --> check_snapshot_balances "before delegation" + +let test_overdelegation = + (* This test assumes that all delegate accounts created in [begin_test] + begin with 4M tz, with 5% staked *) + init_constants () + --> set S.Adaptive_issuance.autostaking_enable true + --> set S.consensus_committee_size 7000 + --> activate_ai `No + --> begin_test + ~force_attest_all:true + ["delegate"; "faucet1"; "faucet2"; "faucet3"] + --> add_account_with_funds + "delegator_to_fund" + ~funder:"delegate" + (Amount (Tez.of_mutez 3_600_000_000_000L)) + (* Delegate has 200k = 5% * 4M staked and 200k liquid *) + --> check_balance_fields + "delegate" + ~liquid:(Tez.of_mutez 200_000_000_000L) + ~staked:(Tez.of_mutez 200_000_000_000L) + () + --> set_delegate "delegator_to_fund" (Some "delegate") + (* Delegate stake will not change at the end of cycle: same stake *) + --> next_cycle + --> check_balance_fields + "delegate" + ~liquid:(Tez.of_mutez 200_000_000_000L) + ~staked:(Tez.of_mutez 200_000_000_000L) + () + --> transfer + "faucet1" + "delegator_to_fund" + (Amount (Tez.of_mutez 3_600_000_000_000L)) + (* Delegate is not overdelegated, but will need to freeze 180k = 5% * 3.6M *) + --> next_cycle + --> check_balance_fields + "delegate" + ~liquid:(Tez.of_mutez 20_000_000_000L) + ~staked:(Tez.of_mutez 380_000_000_000L) + () + --> transfer + "faucet2" + "delegator_to_fund" + (Amount (Tez.of_mutez 3_600_000_000_000L)) + (* Delegate is now overdelegated, it will freeze 100% *) + --> next_cycle + --> check_balance_fields + "delegate" + ~liquid:Tez.zero + ~staked:(Tez.of_mutez 400_000_000_000L) + () + --> transfer + "faucet3" + "delegator_to_fund" + (Amount (Tez.of_mutez 3_600_000_000_000L)) + (* Delegate is overmegadelegated *) + --> next_cycle + --> check_balance_field + "delegator_to_fund" + `Liquid + (Tez.of_mutez 14_400_000_000_000L) + --> check_balance_fields + "delegate" + ~liquid:Tez.zero + ~staked:(Tez.of_mutez 400_000_000_000L) + () + --> transfer + "delegator_to_fund" + "faucet1" + (Amount (Tez.of_mutez 7_200_000_000_000L)) + (* Delegate is not overdelegated anymore, it will freeze 380k = 5% * 7.2M + and unstake 20k *) + --> next_cycle + --> check_balance_fields + "delegate" + ~liquid:Tez.zero + ~staked:(Tez.of_mutez 380_000_000_000L) + ~unstaked_frozen_total:(Tez.of_mutez 20_000_000_000L) + () + (* Unfreezing will be done automatically in + (consensus_rights_delay + max_slashing_period) cycles *) + --> wait_n_cycles_f Test_scenario_stake.unstake_wait + --> check_balance_fields + "delegate" + ~liquid:(Tez.of_mutez 20_000_000_000L) + ~staked:(Tez.of_mutez 380_000_000_000L) + () + +let tests = + tests_of_scenarios + [ + ("Test auto-staking", test_autostaking); + ("Test auto-staking with overdelegation", test_overdelegation); + ] + +let () = + register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "autostaking"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_base.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_base.ml new file mode 100644 index 0000000000000000000000000000000000000000..58199ed65c1a8dfe717ec48ac37577cd41573488 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_base.ml @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Scenario, State + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_base.ml + Subject: Test basic functionality of the scenario framework. +*) + +open Scenario + +let test_expected_error = + assert_failure + ~expected_error:(fun _ -> [Exn (Failure "")]) + (exec (fun _ -> failwith "")) + --> assert_failure + ~expected_error:(fun _ -> [Unexpected_error]) + (assert_failure + ~expected_error:(fun _ -> + [Inconsistent_number_of_bootstrap_accounts]) + (exec (fun _ -> failwith ""))) + +let tests = + tests_of_scenarios + @@ [("Test expected error in assert failure", test_expected_error)] + +let () = register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "base"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_deactivation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_deactivation.ml new file mode 100644 index 0000000000000000000000000000000000000000..764d09bfbe68acd9769596d31f182fac64a13b48 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_deactivation.ml @@ -0,0 +1,158 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol, Consensus, Deactivation + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_deactivation.ml + Subject: Test deactivation in the protocol. +*) + +open State_account +open Tez_helpers.Ez_tez +open Scenario + +let check_is_active ~loc src_name = + let open Lwt_result_syntax in + exec_unit @@ fun (block, state) -> + let src = State.find_account src_name state in + let* b = Context.Delegate.deactivated (B block) src.pkh in + Assert.is_true ~loc (not b) + +let check_is_not_active ~loc src_name = + let open Lwt_result_syntax in + exec_unit @@ fun (block, state) -> + let src = State.find_account src_name state in + let* b = Context.Delegate.deactivated (B block) src.pkh in + Assert.is_true ~loc b + +(** Test that a delegate gets deactivated after a set period of time if it is not baking. + Test that with autostaking, the frozen funds are completely unstaked, which get + finalizable (but not finalized) after a set period of time. + Test that these finalizable funds can indeed be finalized. *) +let test_simple_scenario_with_autostaking = + init_constants () + --> set S.Adaptive_issuance.autostaking_enable true + --> activate_ai `No + --> begin_test ["delegate"; "baker"] + --> set_baker "baker" + --> wait_n_cycles_f (fun (_, state) -> + (2 * state.State.constants.consensus_rights_delay) + 1) + --> check_balance_field "delegate" `Staked (Tez.of_mutez 200_000_000_000L) + --> check_is_active ~loc:__LOC__ "delegate" + --> next_cycle + --> check_is_not_active ~loc:__LOC__ "delegate" + --> check_balance_field "delegate" `Staked Tez.zero + --> check_balance_field + "delegate" + `Unstaked_frozen_total + (Tez.of_mutez 200_000_000_000L) + --> wait_n_cycles_f Test_scenario_stake.unstake_wait + --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero + --> check_balance_field + "delegate" + `Unstaked_finalizable + (Tez.of_mutez 200_000_000_000L) + --> (Tag "Reactivate" + --> set_delegate "delegate" (Some "delegate") + --> check_is_active ~loc:__LOC__ "delegate" + --> next_cycle + --> check_balance_field "delegate" `Unstaked_finalizable Tez.zero + --> check_balance_field + "delegate" + `Staked + (Tez.of_mutez 200_000_000_000L) + |+ Tag "manual finalize unstake" + --> finalize_unstake "delegate" + --> check_balance_field "delegate" `Unstaked_finalizable Tez.zero + --> check_balance_field "delegate" `Staked Tez.zero + --> check_balance_field + "delegate" + `Liquid + (Tez.of_mutez 4_000_000_000_000L)) + +(** Test that a delegate gets deactivated after a set period of time if it is not baking. + Test that with AI, the frozen funds stay frozen, and the delegate can still issue AI + operations without reactivating. *) +let test_simple_scenario_with_ai = + init_constants () --> activate_ai `Force + --> begin_test ["delegate"; "baker"] + --> check_balance_field "delegate" `Staked (Tez.of_mutez 200_000_000_000L) + --> set_baker "baker" + --> wait_n_cycles_f (fun (_, state) -> + (2 * state.State.constants.consensus_rights_delay) + 1) + --> check_balance_field "delegate" `Staked (Tez.of_mutez 200_000_000_000L) + --> check_is_active ~loc:__LOC__ "delegate" + --> next_cycle + --> check_is_not_active ~loc:__LOC__ "delegate" + --> check_balance_field "delegate" `Staked (Tez.of_mutez 200_000_000_000L) + --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero + --> unstake "delegate" All + --> wait_n_cycles_f Test_scenario_stake.unstake_wait + --> finalize_unstake "delegate" + --> check_balance_field "delegate" `Unstaked_finalizable Tez.zero + --> check_balance_field "delegate" `Staked Tez.zero + --> check_balance_field "delegate" `Liquid (Tez.of_mutez 4_000_000_000_000L) + --> check_is_not_active ~loc:__LOC__ "delegate" + --> stake "delegate" Half --> next_cycle + --> check_is_not_active ~loc:__LOC__ "delegate" + +(** Test that a delegate can be deactivated by setting its frozen funds to 0. + Test that a delegate can be activated while having no rights. + Test that a delegate can be deactivated while having rights, and test that it can + still bake while deactivated, hence reactivating *) +let test_baking_deactivation = + init_constants () --> activate_ai `Force + --> begin_test ["delegate"; "baker"] + --> unstake "delegate" All + --> wait_n_cycles_f (fun (_, state) -> + (2 * state.State.constants.consensus_rights_delay) + 1) + --> check_is_active ~loc:__LOC__ "delegate" + --> next_cycle + --> check_is_not_active ~loc:__LOC__ "delegate" + (* Reactivate and wait for rights *) + --> stake "delegate" Half + --> set_delegate "delegate" (Some "delegate") + (* No rights yet, but active *) + --> assert_failure (next_block_with_baker "delegate") + --> check_is_active ~loc:__LOC__ "delegate" + --> wait_n_cycles_f (fun (_, state) -> + state.State.constants.consensus_rights_delay + 1) + --> check_is_active ~loc:__LOC__ "delegate" + --> next_block_with_baker "delegate" + (* Get deactivated by doing nothing *) + --> set_baker "baker" + --> wait_n_cycles_f (fun (_, state) -> + state.State.constants.consensus_rights_delay + 1) + --> check_is_active ~loc:__LOC__ "delegate" + --> next_cycle + --> check_is_not_active ~loc:__LOC__ "delegate" + (* The delegate still has enough rights to bake... *) + --> exec_unit (fun (block, state) -> + let dlgt = State.find_account "delegate" state in + let current_cycle = Block.current_cycle block in + let rights = + CycleMap.find current_cycle dlgt.frozen_rights + |> Option.value ~default:Tez.zero + in + Assert.not_equal_tez ~loc:__LOC__ Tez.zero rights) + --> next_block_with_baker "delegate" + --> check_is_active ~loc:__LOC__ "delegate" + +let tests = + tests_of_scenarios + [ + ( "Test simple deactivation scenario with autostaking", + test_simple_scenario_with_autostaking ); + ("Test simple deactivation scenario with ai", test_simple_scenario_with_ai); + ( "Test deactivation and reactivation scenarios with baking", + test_baking_deactivation ); + ] + +let () = + register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "deactivation"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_rewards.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_rewards.ml new file mode 100644 index 0000000000000000000000000000000000000000..25827edc4311bbe0f9abb153c8a2c6b7aa14c154 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_rewards.ml @@ -0,0 +1,367 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Adaptive Issuance, Rewards + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_rewards.ml + Subject: Test rewards issuance in the protocol. +*) + +open Adaptive_issuance_helpers +open State_account +open Tez_helpers.Ez_tez +open Scenario + +(** Test reward distribution without AI and without autostaking. + [State_account.add_*_rewards] ensures the rewards are distributed + correctly, and it is checked at the end of every block. +*) +let test_wait_rewards_no_ai_no_auto = + (* Prime number to always trigger roundings *) + init_constants ~reward_per_block:1_000_000_007L () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `No + --> begin_test ["delegate1"; "delegate2"; "delegate3"] + --> wait_n_cycles 20 + +(** Test reward distribution without AI and with autostaking. + We expect autostaking to keep the ratio total/frozen equal to + [limit_of_delegation_over_baking + 1], rounding towards frozen. +*) +let test_wait_rewards_no_ai_yes_auto = + let open Lwt_result_syntax in + let check_balanced_balance src_name = + exec_unit (fun (_block, state) -> + let src_balance, src_total = + balance_and_total_balance_of_account src_name state.State.account_map + in + let rat = state.constants.limit_of_delegation_over_baking + 1 in + let expected_frozen = + Tez_helpers.(mul_q src_total Q.(1 // rat) |> of_q ~round:`Up) + in + let* () = + Assert.equal_tez + ~loc:__LOC__ + expected_frozen + (Tez_helpers.of_q ~round:`Down src_balance.staked_b) + in + return_unit) + in + let check_all_balanced_balances = unfold check_balanced_balance in + let all_delegates = ["delegate1"; "delegate2"; "delegate3"] in + init_constants ~reward_per_block:1_000_000_007L () + --> set S.Adaptive_issuance.autostaking_enable true + --> activate_ai `No --> begin_test all_delegates + --> loop + 20 + (exec bake_until_dawn_of_next_cycle + --> check_all_balanced_balances all_delegates + --> next_block) + +(** Tests reward distribution under AI: + - with and without stakers (sometimes overstaking); + - with different values of edge. *) +let test_wait_rewards_with_ai = + let set_edge pct = + let params = + { + limit_of_staking_over_baking = Q.one; + edge_of_baking_over_staking = Q.of_float pct; + } + in + set_delegate_params "delegate" params + in + init_constants ~reward_per_block:1_000_000_007L () + --> activate_ai `Force + --> begin_test ["delegate"; "faucet"] + --> (Tag "edge = 0" --> set_edge 0. + |+ Tag "edge = 0.24" --> set_edge 0.24 + |+ Tag "edge = 0.11... repeating" --> set_edge 0.1111111111 + |+ Tag "edge = 1" --> set_edge 1.) + --> wait_delegate_parameters_activation + --> (Tag "no staker" --> Empty + |+ Tag "one staker" + --> add_account_with_funds + "staker1" + ~funder:"faucet" + (Amount (Tez.of_mutez 2_000_000_000L)) + --> set_delegate "staker1" (Some "delegate") + --> stake "staker1" (Amount (Tez.of_mutez 444_000_111L)) + --> (Empty + |+ Tag "two stakers" + --> add_account_with_funds + "staker2" + ~funder:"faucet" + (Amount (Tez.of_mutez 2_000_000_000L)) + --> set_delegate "staker2" (Some "delegate") + --> stake "staker2" (Amount (Tez.of_mutez 333_001_987L)) + --> (Empty + |+ Tag "three stakers! ha ha ha" + (* This staker overstakes *) + --> add_account_with_funds + "staker3" + ~funder:"faucet" + (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> set_delegate "staker3" (Some "delegate") + --> stake + "staker3" + (Amount (Tez.of_mutez 1_799_123_456_788L)) + --> exec_unit (fun (_, state) -> + let src = State.find_account "delegate" state in + let self_frozen = + src.frozen_deposits.self_current + in + let staked = + Frozen_tez.total_co_current_q + src.frozen_deposits.co_current + in + Assert.is_true + ~loc:__LOC__ + Q.( + Tez.mul_q + self_frozen + src.parameters.limit_of_staking_over_baking + < staked))))) + --> set_baker "delegate" --> wait_n_cycles 20 + +(** Tests reward distribution under AI for one baker and one staker, + and different arbitrary events: + staking, unstaking, finalizing, slashing *) +let test_wait_rewards_with_ai_staker_variation = + let set_edge pct = + let params = + { + limit_of_staking_over_baking = Q.one; + edge_of_baking_over_staking = Q.of_float pct; + } + in + set_delegate_params "delegate" params + in + init_constants ~reward_per_block:1_000_000_007L () + --> activate_ai `Force + --> begin_test ["delegate"; "faucet"] + --> set_edge 0.24 --> wait_delegate_parameters_activation + --> add_account_with_funds + "staker" + ~funder:"faucet" + (Amount (Tez.of_mutez 20_000_000_000L)) + --> set_delegate "staker" (Some "delegate") + --> stake "staker" (Amount (Tez.of_mutez 12_444_000_111L)) + --> set_baker "delegate" + (* Regular rewards *) + --> wait_n_cycles 7 + (* Staker unstakes some *) + --> unstake "staker" Half + --> wait_n_cycles 4 + (* Staker restakes some *) + --> stake "staker" Half + (* Reactivate another baker for allowing it to bake later *) + --> set_delegate "faucet" (Some "faucet") + --> wait_n_cycles 4 + (* Add unstake requests in the mix *) + --> unstake "staker" Half + --> next_cycle + (* Double bake for the delegate *) + --> set_baker "faucet" + --> double_bake "delegate" --> make_denunciations () + (* Wait for the delegate to not be forbidden anymore *) + --> wait_n_cycles 10 + (* Reactivate it, make it bake, and see everything is as before *) + --> set_delegate "delegate" (Some "delegate") + --> wait_n_cycles 4 --> set_baker "delegate" --> wait_n_cycles 10 + +(** Tests reward distribution under AI for one baker and two stakers, + and the baker changes its limit parameter while being overstaked. + We expect the rewards for the stakers to change accordingly with the limit. +*) +let test_overstake_different_limits = + let set_limit l = + let params = + { + limit_of_staking_over_baking = Q.of_float l; + edge_of_baking_over_staking = Q.zero; + } + in + set_delegate_params "delegate" params + in + init_constants ~reward_per_block:1_000_000_007L () + --> activate_ai `Force + --> begin_test ["delegate"; "faucet"] + --> set_baker "faucet" + --> unstake "delegate" (Amount (Tez.of_mutez 190_000_000_000L)) + --> check_balance_field "delegate" `Staked (Tez.of_mutez 10_000_000_000L) + --> set_baker "delegate" + (* same rights to have same block distribution *) + --> unstake "faucet" (Amount (Tez.of_mutez 190_000_000_000L)) + --> unstake "__bootstrap__" (Amount (Tez.of_mutez 190_000_000_000L)) + --> set_limit 5. --> wait_delegate_parameters_activation + --> add_account_with_funds + "staker1" + ~funder:"faucet" + (Amount (Tez.of_mutez 400_000_000_000L)) + --> set_delegate "staker1" (Some "delegate") + --> add_account_with_funds + "staker2" + ~funder:"faucet" + (Amount (Tez.of_mutez 400_000_000_000L)) + --> set_delegate "staker2" (Some "delegate") + (* Always overstaked *) + --> stake "staker1" (Amount (Tez.of_mutez 111_000_000_000L)) + --> stake "staker2" (Amount (Tez.of_mutez 222_000_000_000L)) + --> (Tag "limit = 0" --> set_limit 0. + |+ Tag "limit = 0.24" --> set_limit 0.24 + |+ Tag "limit = 1" --> set_limit 1. + |+ Tag "limit >= 5" --> set_limit 6.) + (* Before activation: testing global limit (5) *) + --> wait_delegate_parameters_activation + --> wait_n_cycles 6 + --> (Tag "limit = 0" --> set_limit 0. + |+ Tag "limit = 0.24" --> set_limit 0.24 + |+ Tag "limit = 1" --> set_limit 1. + |+ Tag "limit >= 5" --> set_limit 6.) + --> wait_delegate_parameters_activation --> wait_n_cycles 6 + +(** Tests that the activation time for AI is as expected: + The expected delay is [consensus_rights_delay] + 1 cycles after activation. *) +let test_ai_curve_activation_time = + let consensus_rights_delay (_, state) = + state.State.constants.consensus_rights_delay + in + init_constants ~reward_per_block:1_000_000_000L ~deactivate_dynamic:true () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Zero_threshold + --> begin_test ~burn_rewards:true [""] + --> next_block --> save_current_rate (* before AI rate *) + --> wait_ai_activation + (* Rate remains unchanged right after AI activation, we must wait [pc + 1] cycles *) + --> check_rate_evolution Q.equal + --> wait_n_cycles_f consensus_rights_delay + --> check_rate_evolution Q.equal + --> next_cycle + (* The new rate should be active now. With the chosen constants, it should be lower. + We go from 1000tz per day to (at most) 5% of 4_000_000tz per year *) + --> check_rate_evolution Q.gt + +(** Integration test for Adaptive Issuance. + Tests that the curve is decreasing wrt stake ratio. *) +let test_static_decreasing = + let rate_var_lag = Default_parameters.constants_test.consensus_rights_delay in + let delta = Amount (Tez.of_mutez 20_000_000_000L) in + let q_almost_equal x y = + let rat = Q.div x y in + (* ~ inverse square root of total supply *) + let epsilon = Q.(1 // 100_000) in + Q.(rat >= one - epsilon && rat <= one + epsilon) + in + let cycle_stake = + save_current_rate --> stake "delegate" delta --> next_cycle + --> check_rate_evolution Q.gt + in + let cycle_unstake = + save_current_rate --> unstake "delegate" delta --> next_cycle + --> check_rate_evolution Q.lt + in + let cycle_stable = + save_current_rate --> next_cycle --> check_rate_evolution q_almost_equal + in + init_constants ~reward_per_block:1L ~deactivate_dynamic:true () + (* Set rate bounds that should not be reached *) + --> set S.Adaptive_issuance.autostaking_enable false + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_final_min + Q.(1 // 100_000) + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_initial_min + Q.(1 // 100_000) + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_final_max + Q.one + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_initial_max + Q.one + --> activate_ai `Zero_threshold + --> begin_test ~burn_rewards:true ["delegate"] + --> next_block --> wait_ai_activation + (* We stake about 50% of the total supply *) + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> stake "__bootstrap__" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> (Tag "increase stake, decrease rate" --> next_cycle + --> loop rate_var_lag (stake "delegate" delta --> next_cycle) + --> loop 10 cycle_stake + |+ Tag "decrease stake, increase rate" --> next_cycle + --> loop rate_var_lag (unstake "delegate" delta --> next_cycle) + --> loop 10 cycle_unstake + |+ Tag "stable stake, stable rate" --> next_cycle + --> wait_n_cycles rate_var_lag --> loop 10 cycle_stable) + +(** Integration test for Adaptive Issuance. + Tests that the curve is updated for stake movement only after + [consensus_rights_delay] cycles. *) +let test_static_timing = + let consensus_rights_delay (_block, state) = + state.State.constants.consensus_rights_delay + in + let delta = Amount (Tez.of_mutez 20_000_000_000L) in + let q_almost_equal x y = + let rat = Q.div x y in + (* ~ inverse square root of total supply *) + let epsilon = Q.(1 // 100_000) in + Q.(rat >= one - epsilon && rat <= one + epsilon) + in + init_constants ~reward_per_block:1L ~deactivate_dynamic:true () + (* Set rate bounds that should not be reached *) + --> set S.Adaptive_issuance.autostaking_enable false + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_final_min + Q.(1 // 100_000) + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_initial_min + Q.(1 // 100_000) + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_final_max + Q.one + --> set + S.Adaptive_issuance.Adaptive_rewards_params.issuance_ratio_initial_max + Q.one + --> activate_ai `Force + --> begin_test ~burn_rewards:true ["delegate"] + (* We stake about 50% of the total supply *) + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> stake "__bootstrap__" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> wait_n_cycles_f (fun x -> consensus_rights_delay x + 1) + --> save_current_rate + --> (Tag "increase stake" --> stake "delegate" delta + --> wait_n_cycles_f consensus_rights_delay + --> check_rate_evolution q_almost_equal + --> next_cycle --> check_rate_evolution Q.gt + |+ Tag "decrease stake" --> unstake "delegate" delta + --> wait_n_cycles_f consensus_rights_delay + --> check_rate_evolution q_almost_equal + --> next_cycle --> check_rate_evolution Q.lt) + +let tests = + tests_of_scenarios + @@ [ + ("Test wait rewards no AI no autostake", test_wait_rewards_no_ai_no_auto); + ( "Test wait rewards no AI yes autostake", + test_wait_rewards_no_ai_yes_auto ); + ("Test wait rewards with AI, stakers and edge", test_wait_rewards_with_ai); + ( "Test wait rewards with AI and stake variation events", + test_wait_rewards_with_ai_staker_variation ); + ("Test ai curve activation time", test_ai_curve_activation_time); + ( "Test static rate decreasing with stake ratio increasing", + test_static_decreasing ); + ( "Test static rate updated after consensus_rights_delay", + test_static_timing ); + ( "Test limit parameter with overstake and rewards", + test_overstake_different_limits ); + ] + +let () = + register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "rewards"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing.ml new file mode 100644 index 0000000000000000000000000000000000000000..3cdedd52d8d564a0a17fa965a5004306ae414730 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing.ml @@ -0,0 +1,386 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 Nomadic Labs *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Adaptive Issuance, Slashing + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_slashing.ml + Subject: Test slashing scenarios in the protocol. +*) + +open State_account +open Tez_helpers.Ez_tez +open Scenario +open Scenario_constants + +let fs = Format.asprintf + +(** Test multiple misbehaviors + - Test a single delegate misbehaving multiple times + - Test multiple delegates misbehaving + - Test multiple delegates misbehaving multiple times + - Test denunciation at once or in a staggered way + - Test denunciation in chronological order or reverse order + - Spread misbehaviors/denunciations over multiple cycles + *) +let test_multiple_misbehaviors = + (* Denounce all misbehaviours or 14 one by one in chronological or reverse + order *) + let make_denunciations () = + Tag "denounce chronologically" + --> log "denounce chronologically" + --> (Tag "all at once" --> make_denunciations ~rev:false () + |+ Tag "one by one" + --> loop + 12 + (make_denunciations + ~filter:(fun {denounced; _} -> not denounced) + ~single:true + ~rev:false + ())) + |+ Tag "denounce reverse" --> log "denounce reverse" + --> (Tag "all at once" --> make_denunciations ~rev:true () + |+ Tag "one by one" + --> loop + 12 + (make_denunciations + ~filter:(fun {denounced; _} -> not denounced) + ~single:true + ~rev:true + ())) + in + (* Misbehaviors scenarios *) + let misbehave i delegate1 delegate2 = + (Tag "single delegate" + (* A single delegate misbehaves several times before being denunced *) + --> loop + i + (double_attest delegate1 --> double_preattest delegate1 + --> double_bake delegate1 --> double_attest delegate1 + --> double_preattest delegate1) + --> exclude_bakers [delegate1] + |+ Tag "multiple delegates" + (* Two delegates double bake sequentially *) + --> loop + i + (loop + 3 + (double_bake delegate1 --> double_bake delegate2 --> next_block)) + --> exclude_bakers [delegate1; delegate2] + |+ Tag "double misbehaviors" + (* Two delegates misbehave in parallel for multiple levels *) + --> loop + i + (double_attest_many [delegate1; delegate2] + --> double_attest_many [delegate1; delegate2] + --> double_preattest_many [delegate1; delegate2] + --> double_bake_many [delegate1; delegate2]) + --> exclude_bakers [delegate1; delegate2]) + --> make_denunciations () + in + init_constants ~blocks_per_cycle:24l ~reward_per_block:0L () + --> set S.Adaptive_issuance.autostaking_enable false + --> (Tag "No AI" --> activate_ai `No |+ Tag "Yes AI" --> activate_ai `Force) + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "bootstrap1"; "bootstrap2"; "bootstrap3"] + --> next_cycle + --> (* various make misbehaviors spread over 1 or two cycles *) + List.fold_left + (fun acc i -> + acc + |+ Tag (string_of_int i ^ " misbehavior loops") + --> misbehave i "delegate" "bootstrap1" + --> next_cycle) + Empty + [1; 3] + +let check_is_forbidden baker = assert_failure (next_block_with_baker baker) + +let check_is_not_forbidden baker = + let open Lwt_result_syntax in + exec (fun ((block, state) as input) -> + let baker = State.find_account baker state in + let* _ = Block.bake ~policy:(By_account baker.pkh) block in + return input) + +(** Tests forbidding delegates ensuring: + - delegates are not forbidden until a denunciation is made (allowing for + multiple misbehaviours) + - a single misbehaviour is enough to be denunced and forbidden + - delegates are unforbidden after a certain amount of time + - delegates are not forbidden if denounced for an outdated misbehaviour +*) +let test_delegate_forbidden = + let crd (_, state) = state.State.constants.consensus_rights_delay in + init_constants ~blocks_per_cycle:32l () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `No + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "bootstrap1"; "bootstrap2"] + --> set_baker "bootstrap1" + --> (Tag "Is not forbidden until first denunciation" + --> loop 14 (double_bake "delegate") + --> exclude_bakers ["delegate"] + --> (* ensure delegate is not forbidden until the denunciations are done *) + check_is_not_forbidden "delegate" + --> make_denunciations () + --> (* delegate is forbidden directly after the first denunciation *) + check_is_forbidden "delegate" + |+ Tag "Is forbidden after single misbehavior" + --> double_attest "delegate" + --> (Tag "very early first denounce" + --> exclude_bakers ["delegate"] + --> make_denunciations () + |+ Tag "in next cycle" --> next_cycle + --> exclude_bakers ["delegate"] + --> make_denunciations ()) + --> check_is_forbidden "delegate" + |+ Tag "Is unforbidden after CONSENSUS_RIGHTS_DELAY after slash cycles" + --> double_attest "delegate" + --> exclude_bakers ["delegate"] + --> make_denunciations () + --> check_is_forbidden "delegate" + --> next_cycle (* slash occured *) --> stake "delegate" Half + --> wait_n_cycles_f crd + --> check_is_not_forbidden "delegate" + |+ Tag "Is not forbidden after a denunciation is outdated" + --> double_attest "delegate" --> wait_n_cycles 2 + --> assert_failure (make_denunciations ()) + --> check_is_not_forbidden "delegate" + |+ Tag + "Two double attestations, in consecutive cycles, denounce out of \ + order" --> double_attest "delegate" --> next_cycle + --> double_attest "delegate" + --> make_denunciations + ~filter:(fun {denounced; misbehaviour = {level; _}; _} -> + (not denounced) && Protocol.Raw_level_repr.to_int32 level > 10l) + () + --> make_denunciations + ~filter:(fun {denounced; misbehaviour = {level; _}; _} -> + (not denounced) + && Protocol.Raw_level_repr.to_int32 level <= 10l) + () + --> check_is_forbidden "delegate") + +let test_slash_unstake = + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `No + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "bootstrap1"; "bootstrap2"] + --> set_baker "bootstrap1" --> next_cycle --> unstake "delegate" Half + --> next_cycle --> double_bake "delegate" --> make_denunciations () + --> (Empty |+ Tag "unstake twice" --> unstake "delegate" Half) + --> wait_n_cycles 5 + --> finalize_unstake "delegate" + +let test_slash_monotonous_stake = + let scenario ~offending_op ~op ~early_d = + init_constants ~blocks_per_cycle:16l () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `No + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "bootstrap1"] + --> next_cycle + --> loop + 6 + (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) --> next_cycle) + --> offending_op "delegate" + --> (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) + --> loop + 2 + (op "delegate" (Amount (Tez.of_mutez 1_000_000_000L)) + --> + if early_d then + make_denunciations () + --> exclude_bakers ["delegate"] + --> next_block + else offending_op "delegate" --> next_block)) + in + Tag "slashes with increasing stake" + --> (Tag "denounce early" + --> (Tag "Double Bake" + --> scenario ~offending_op:double_bake ~op:stake ~early_d:true + |+ Tag "Double attest" + --> scenario + ~offending_op:(fun s -> double_attest s) + ~op:stake + ~early_d:true) + |+ Tag "denounce late" + --> (Tag "Double Bake" + --> scenario ~offending_op:double_bake ~op:stake ~early_d:false + |+ Tag "Double attest" + --> scenario + ~offending_op:(fun s -> double_attest s) + ~op:stake + ~early_d:false) + --> make_denunciations ()) + |+ Tag "slashes with decreasing stake" + --> (Tag "Double Bake" + --> scenario ~offending_op:double_bake ~op:unstake ~early_d:true + |+ Tag "Double attest" + --> scenario + ~offending_op:(fun s -> double_attest s) + ~op:unstake + ~early_d:true) + |+ Tag "denounce late" + --> (Tag "Double Bake" + --> scenario ~offending_op:double_bake ~op:unstake ~early_d:false + |+ Tag "Double attest" + --> scenario + ~offending_op:(fun s -> double_attest s) + ~op:unstake + ~early_d:false) + --> make_denunciations () + +let test_slash_timing = + init_constants ~blocks_per_cycle:8l () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `No + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "bootstrap1"] + --> next_cycle + --> (Tag "stake" --> stake "delegate" Half + |+ Tag "unstake" --> unstake "delegate" Half) + --> (Tag "with a first slash" --> double_bake "delegate" + --> exclude_bakers ["delegate"] + --> make_denunciations () + |+ Tag "without another slash" --> Empty) + --> stake "delegate" Half + --> List.fold_left + (fun acc i -> + acc |+ Tag (string_of_int i ^ " cycles lag") --> wait_n_cycles i) + (wait_n_cycles 2) + [3; 4; 5; 6] + --> double_bake "delegate" + --> exclude_bakers ["delegate"] + --> make_denunciations () --> next_cycle + +let test_no_shortcut_for_cheaters = + let amount = Amount (Tez.of_mutez 333_000_000_000L) in + let consensus_rights_delay = + Default_parameters.constants_test.consensus_rights_delay + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> begin_test ["delegate"; "bootstrap1"] + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> next_cycle --> double_bake "delegate" --> make_denunciations () + --> set_baker "bootstrap1" (* exclude_bakers ["delegate"] *) + --> next_cycle + --> snapshot_balances "init" ["delegate"] + --> unstake "delegate" amount + --> (List.fold_left + (fun acc i -> acc |+ Tag (fs "wait %i cycles" i) --> wait_n_cycles i) + (Tag "wait 0 cycles" --> Empty) + (Stdlib.List.init (consensus_rights_delay - 1) (fun i -> i + 1)) + --> stake "delegate" amount + --> assert_failure (check_snapshot_balances "init") + |+ Tag "wait enough cycles (consensus_rights_delay + 1)" + --> wait_n_cycles (consensus_rights_delay + 1) + --> stake "delegate" amount + --> check_snapshot_balances "init") + +let test_slash_correct_amount_after_stake_from_unstake = + let amount_to_unstake = Amount (Tez.of_mutez 200_000_000_000L) in + let amount_to_restake = Amount (Tez.of_mutez 100_000_000_000L) in + let amount_expected_in_unstake_after_slash = Tez.of_mutez 50_000_000_000L in + let consensus_rights_delay = + Default_parameters.constants_test.consensus_rights_delay + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> begin_test ["delegate"; "bootstrap1"] + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> next_cycle + --> unstake "delegate" amount_to_unstake + --> stake "delegate" amount_to_restake + --> List.fold_left + (fun acc i -> acc |+ Tag (fs "wait %i cycles" i) --> wait_n_cycles i) + (Tag "wait 0 cycles" --> Empty) + (Stdlib.List.init (consensus_rights_delay - 2) (fun i -> i + 1)) + --> double_attest "delegate" --> make_denunciations () + --> exclude_bakers ["delegate"] + --> next_cycle + --> check_balance_field + "delegate" + `Unstaked_frozen_total + amount_expected_in_unstake_after_slash + +(* Test a non-zero request finalizes for a non-zero amount if it hasn't been slashed 100% *) +let test_mini_slash = + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> (Tag "Yes AI" --> activate_ai `Force --> begin_test ["delegate"; "baker"] + |+ Tag "No AI" --> activate_ai `No --> begin_test ["delegate"; "baker"]) + --> unstake "delegate" (Amount Tez.one_mutez) + --> set_baker "baker" --> next_cycle + --> (Tag "5% slash" --> double_bake "delegate" --> make_denunciations () + |+ Tag "95% slash" --> next_cycle --> double_attest "delegate" + --> loop 9 (double_bake "delegate") + --> make_denunciations ()) + (* Wait two cycles because of ns_enable *) + --> next_cycle + --> next_cycle + --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero + --> wait_n_cycles_f (fun (_, state) -> + state.constants.consensus_rights_delay + 1) + +let test_slash_rounding = + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test ["delegate"; "baker"] + --> set_baker "baker" + --> unstake "delegate" (Amount (Tez.of_mutez 2L)) + --> next_cycle --> double_bake "delegate" --> double_bake "delegate" + --> make_denunciations () --> wait_n_cycles 7 + --> finalize_unstake "delegate" + +(* TODO #6645: reactivate tests *) +let tests = + tests_of_scenarios + @@ [ + ("Test multiple misbehaviors", test_multiple_misbehaviors); + ("Test slashed is forbidden", test_delegate_forbidden); + ("Test slash with unstake", test_slash_unstake); + (* TODO: make sure this test passes with blocks_per_cycle:8l + https://gitlab.com/tezos/tezos/-/issues/6904 *) + ("Test slashes with simple varying stake", test_slash_monotonous_stake); + ("Test slash timing", test_slash_timing); + ( "Test stake from unstake deactivated when slashed", + test_no_shortcut_for_cheaters ); + ( "Test stake from unstake reduce initial amount", + test_slash_correct_amount_after_stake_from_unstake ); + ("Test unstake 1 mutez then slash", test_mini_slash); + ("Test slash rounding", test_slash_rounding); + ] + +let () = + register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "slashing"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing_stakers.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing_stakers.ml new file mode 100644 index 0000000000000000000000000000000000000000..5d87e7d267bd85c4cf46ff1e0eca876d653967d2 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing_stakers.ml @@ -0,0 +1,193 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Adaptive Issuance, Slashing with Stakers + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_slashing_stakers.ml + Subject: Test slashing scenarios in the protocol with stakers. +*) + +open Adaptive_issuance_helpers +open State_account +open Tez_helpers.Ez_tez +open Scenario +open Scenario_constants + +let fs = Format.asprintf + +let slashed_staker_1 = "staker1" + +let slashed_staker_2 = "staker2" + +let never_slashed_staker = "staker3" + +let first_slashed_delegate = "delegate" + +let second_slashed_delegate = "bootstrap1" + +let never_slashed_delegate1 = "bootstrap2" + +let never_slashed_delegate2 = "bootstrap3" + +(** Setup starting state for test with + - 4 delegates + - potentialy three stakers (2 delegating to first_slashed_delegate and 1 to + never_slashed_delegate1 respectively) + - AI enabled + - ns_enable enabled/disabled + - alternative parameters for first_slashed_delegate and + never_slashed_delegate1 +*) +let init_with_stakers () = + let init_params l e = + {limit_of_staking_over_baking = l; edge_of_baking_over_staking = e} + in + (* Same edge for both delegates to avoid test branches explosion *) + let set_delegate_params dlgt1 dlgt2 = + (Tag "edge 1" + --> set_delegate_params dlgt1 (init_params Q.one Q.one) + --> set_delegate_params dlgt2 (init_params Q.one Q.one) + |+ Tag "edge 1/3" + --> set_delegate_params dlgt1 (init_params Q.one Q.(1 // 3)) + --> set_delegate_params dlgt2 (init_params Q.one Q.(1 // 3))) + --> wait_n_cycles 4 + in + let add_staker name delegate amount staked_amount = + add_account_with_funds name ~funder:delegate (Amount (Tez.of_mutez amount)) + --> set_delegate name (Some delegate) + --> stake name staked_amount + in + let add_stakers = + Tag "with stakers" + --> add_staker + slashed_staker_1 + first_slashed_delegate + 1_000_000_000_000L + Half + --> add_staker slashed_staker_2 first_slashed_delegate 3_333_333L Half + --> add_staker + never_slashed_staker + never_slashed_delegate1 + 1_000_000_000L + Half + |+ Empty + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> branch_flag S.Adaptive_issuance.ns_enable + --> begin_test + [ + first_slashed_delegate; + second_slashed_delegate; + never_slashed_delegate1; + never_slashed_delegate2; + ] + --> set_delegate_params first_slashed_delegate never_slashed_delegate1 + --> add_stakers + +(** Starts with four delegates, misbhehaves with one, denounce it, and + potentially do it again with another delegate. + Alternative scenarios include: + - all three misbehaviors + - delegates with/without stakers to observe sharing of slashing and rewards, + - denunciations be made in the same cycle, in the next or too late + - several staking parameters + *) +let test_simple_slash = + let open Lwt_result_syntax in + let any_slash delegate = + Tag "double baking" --> double_bake delegate + |+ Tag "double attesting" + --> double_attest + ~other_bakers:(never_slashed_delegate1, never_slashed_delegate2) + delegate + |+ Tag "double preattesting" + --> double_preattest + ~other_bakers:(never_slashed_delegate1, never_slashed_delegate2) + delegate + in + init_with_stakers () + --> any_slash first_slashed_delegate + --> log "make denunciations" + --> snapshot_balances "before slash" [first_slashed_delegate] + --> ((Tag "denounce same cycle" --> make_denunciations () + (* delegate can be forbidden in this case, so we exclude it from list of potential bakers *) + --> exclude_bakers [first_slashed_delegate] + |+ Tag "denounce next cycle" --> next_cycle --> make_denunciations () + (* delegate can be forbidden in this case, so we set another baker *) + --> exclude_bakers [first_slashed_delegate]) + --> (Tag "denouncer with maybe staker" + --> set_baker never_slashed_delegate1 + (* ensure denunciation is included by never_slashed_delegate1 *) + |+ Tag "denouncer without staker" + --> set_baker never_slashed_delegate2) + --> next_block + --> (* only exclude "delegate" *) exclude_bakers [first_slashed_delegate] + --> (Empty + |+ Tag "another slash" + --> any_slash second_slashed_delegate + --> make_denunciations () + (* bootstrap1 can be forbidden in this case, so we exclude it from list of potential bakers *) + --> exclude_bakers + [first_slashed_delegate; second_slashed_delegate]) + --> check_snapshot_balances "before slash" + --> exec_unit (check_pending_slashings ~loc:__LOC__) + --> next_cycle + --> assert_failure + (exec_unit (fun (_block, state) -> + if State_ai_flags.Delayed_slashing.enabled state then + failwith "ns_enable = true: slash not applied yet" + else return_unit) + --> check_snapshot_balances "before slash") + --> exec_unit (check_pending_slashings ~loc:__LOC__) + --> next_cycle + |+ Tag "denounce too late" --> next_cycle --> next_cycle + --> assert_failure + ~expected_error:(fun (_block, state) -> + let ds = state.State.double_signings in + let ds = match ds with [a] -> a | _ -> assert false in + let level = + Protocol.Alpha_context.Raw_level.Internal_for_tests.from_repr + ds.misbehaviour.level + in + let last_cycle = + Cycle.add + (Block.current_cycle_of_level + ~blocks_per_cycle:state.State.constants.blocks_per_cycle + ~current_level: + (Protocol.Raw_level_repr.to_int32 + ds.misbehaviour.level)) + Protocol.Constants_repr.max_slashing_period + in + let (kind : Protocol.Alpha_context.Misbehaviour.kind) = + (* This conversion would not be needed if + Misbehaviour_repr.kind were moved to a + separate file that doesn't have under/over + Alpha_context versions. *) + match ds.misbehaviour.kind with + | Double_baking -> Double_baking + | Double_attesting -> Double_attesting + | Double_preattesting -> Double_preattesting + in + [ + Environment.Ecoproto_error + (Protocol.Validate_errors.Anonymous.Outdated_denunciation + {kind; level; last_cycle}); + ]) + (make_denunciations ()) + --> check_snapshot_balances "before slash") + +let tests = tests_of_scenarios @@ [("Test simple slashing", test_simple_slash)] + +let () = + register_tests + ~__FILE__ + ~tags:["protocol"; "scenario"; "slashing"; "stakers"] + tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_stake.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_stake.ml new file mode 100644 index 0000000000000000000000000000000000000000..d631f74f5b84504fb8ff4f6ca6a172dd63984384 --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_stake.ml @@ -0,0 +1,596 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Adaptive Issuance, Staking + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/main.exe \ + -- --file test_scenario_stake.ml + Subject: Test staking operations in the protocol. +*) + +open Adaptive_issuance_helpers +open State_account +open Tez_helpers.Ez_tez +open Scenario + +let fs = Format.asprintf + +(** Initializes of scenarios with 2 cases: + - staker = delegate + - staker != delegate + Any scenario that begins with this will be duplicated. + + Also, ensures that AI is activated (sets EMA threshold to zero, + enables activation vote, and waits for AI activation). *) +let init_staker_delegate_or_external = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + let begin_test ~self_stake = + let name = if self_stake then "staker" else "delegate" in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> Scenario_begin.activate_ai `Force + --> begin_test [name] + --> set_delegate_params name init_params + in + Tag "AI activated" + --> (Tag "self stake" --> begin_test ~self_stake:true + |+ Tag "external stake" + --> begin_test ~self_stake:false + --> add_account_with_funds + "staker" + ~funder:"delegate" + (Amount (Tez.of_mutez 2_000_000_000_000L)) + --> set_delegate "staker" (Some "delegate")) + --> wait_delegate_parameters_activation + +let stake_init = + stake "staker" Half + --> (Tag "no wait after stake" --> Empty + |+ Tag "wait after stake" --> wait_n_cycles 2) + +let ( -- ) a b x = a x - b + +let ( ++ ) a b x = a x + b + +let wait_for_unfreeze_and_check wait = + snapshot_balances "wait snap" ["staker"] + --> wait_n_cycles_f (wait -- 1) + (* Balance didn't change yet, but will change next cycle *) + --> check_snapshot_balances "wait snap" + --> next_cycle + --> assert_failure (check_snapshot_balances "wait snap") + +let unstake_wait (_, state) = + let crd = state.State.constants.consensus_rights_delay in + let msp = Protocol.Constants_repr.max_slashing_period in + crd + msp + +let finalize staker = + assert_failure (check_balance_field staker `Unstaked_finalizable Tez.zero) + --> finalize_unstake staker + --> check_balance_field staker `Unstaked_finalizable Tez.zero + +(* Simple stake - unstake - finalize roundtrip. + + - Note that the test framework automatically checks, whenever a + block is baked, that the staker's fully detailed balance (liquid, + bonds, staked, unstaked frozen, unstaked finalizable, and costaking + values) is the same as predicted in the simulated state. + + - Moreover, we explicitly check that after the unstake operation, + the staker's balance doesn't change until the last cycle of the + unfreeze delay (which is [consensus_rights_delay + + max_slashing_period = 2 + 2]). *) +let simple_roundtrip = + init_staker_delegate_or_external --> stake_init + --> (Tag "full unstake" --> unstake "staker" All + |+ Tag "half unstake" --> unstake "staker" Half) + --> wait_for_unfreeze_and_check unstake_wait + --> finalize "staker" --> next_cycle + +(* Same as above, except with two separate unstake operations. *) +let double_roundtrip = + init_staker_delegate_or_external --> stake_init --> unstake "staker" Half + --> (Tag "half then full unstake" --> wait_n_cycles 2 --> unstake "staker" All + |+ Tag "half then half unstake" --> wait_n_cycles 2 + --> unstake "staker" Half) + --> wait_for_unfreeze_and_check (unstake_wait -- 2) + --> wait_for_unfreeze_and_check (Fun.const 2) + --> finalize "staker" --> next_cycle + +(* Roundtrip where the unstaked amount matches the initially staked + amount (either from one unstake operation of this amount, or two + unstake operations summing up to it). This lets us explicitly check + that the detailed balance of the staker at the end is identical to + its balance before the stake operation. *) +let status_quo_rountrip = + let full_amount = Tez.of_mutez 10_000_000L in + let amount_1 = Tez.of_mutez 2_999_999L in + let amount_2 = Tez.of_mutez 7_000_001L in + init_staker_delegate_or_external + --> snapshot_balances "init" ["staker"] + --> stake "staker" (Amount full_amount) + --> next_cycle + --> (Tag "1 unstake" --> unstake "staker" (Amount full_amount) + |+ Tag "2 unstakes" + --> unstake "staker" (Amount amount_1) + --> next_cycle + --> unstake "staker" (Amount amount_2)) + --> wait_n_cycles_f unstake_wait + --> finalize "staker" + --> check_snapshot_balances "init" + +(* Test that a baker can stake from unstaked frozen funds. + The most recent unstakes are prioritized when staking. *) +let shorter_roundtrip_for_baker = + let unstake_amount = Amount (Tez.of_mutez 222_000_000_000L) in + let consensus_rights_delay = + Default_parameters.constants_mainnet.consensus_rights_delay + (* mainnet value, = 2 *) + in + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> set S.consensus_rights_delay consensus_rights_delay + --> activate_ai `Force + --> begin_test ["delegate"; "faucet"] + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> set_delegate_params "delegate" init_params + --> add_account_with_funds + "staker1" + ~funder:"faucet" + (Amount (Tez.of_mutez 200_000_000_000L)) + --> add_account_with_funds + "staker2" + ~funder:"faucet" + (Amount (Tez.of_mutez 200_000_000_000L)) + --> wait_delegate_parameters_activation + --> set_delegate "staker1" (Some "delegate") + --> set_delegate "staker2" (Some "delegate") + --> stake "staker1" Half --> stake "staker2" Half + --> + (* From now on, staker1 unstakes every cycle to fill all the containers, but + this shouldn't change anything for the baker *) + let next_cycle = unstake "staker1" Half --> next_cycle in + next_cycle + (* We unstake to have an amount in the last container for ufd *) + --> unstake "delegate" unstake_amount + --> next_cycle + (* We unstake either one, two or three cycles later *) + --> (Tag "unstake cycle (current-2)" + --> unstake "delegate" unstake_amount + --> next_cycle --> next_cycle + |+ Tag "unstake cycle (current-1)" --> next_cycle + --> unstake "delegate" unstake_amount + --> next_cycle + |+ Tag "unstake cycle (current)" --> next_cycle --> next_cycle + --> unstake "delegate" unstake_amount) + (* Nothing is finalizable yet. If nothing else happens, next cycle the + first unstake request will become finalizable. *) + --> check_balance_field "delegate" `Unstaked_finalizable Tez.zero + --> (Tag "stake from unstake one container" + --> (Tag "one stake" + --> stake "delegate" (Amount (Tez.of_mutez 111_000_000_000L)) + |+ Tag "two stakes" + --> stake "delegate" (Amount (Tez.of_mutez 100_000_000_000L)) + --> stake "delegate" (Amount (Tez.of_mutez 11_000_000_000L))) + --> check_balance_field + "delegate" + `Unstaked_frozen_total + (Tez.of_mutez 333_000_000_000L) + (* We only removed unstake from the most recent unstake: we should + expect the first unstake request to finalize with its full amount on the next cycle *) + --> next_cycle + --> check_balance_field + "delegate" + `Unstaked_finalizable + (Tez.of_mutez 222_000_000_000L) + --> check_balance_field + "delegate" + `Unstaked_frozen_total + (Tez.of_mutez 111_000_000_000L) + |+ Tag "stake from unstake two containers" + --> stake "delegate" (Amount (Tez.of_mutez 333_000_000_000L)) + --> check_balance_field + "delegate" + `Unstaked_frozen_total + (Tez.of_mutez 111_000_000_000L) + (* We should have removed all the unstake from the most recent container. + The rest will be finalizable next cycle. *) + --> next_cycle + --> check_balance_field + "delegate" + `Unstaked_finalizable + (Tez.of_mutez 111_000_000_000L) + --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero + |+ Tag "stake from all unstaked + liquid" + --> stake "delegate" (Amount (Tez.of_mutez 555_000_000_000L)) + (* Nothing remains unstaked *) + --> check_balance_field "delegate" `Unstaked_frozen_total Tez.zero + --> check_balance_field "delegate" `Unstaked_finalizable Tez.zero) + +(* Test three different ways to finalize unstake requests: + - finalize_unstake operation + - stake operation (of 1 mutez) + - unstake operation (of 1 mutez) + + Check that the finalizable unstaked balance is non-zero before, and + becomes zero after the finalization. *) +let scenario_finalize = + init_staker_delegate_or_external --> stake "staker" Half --> next_cycle + --> unstake "staker" Half + --> wait_n_cycles_f unstake_wait + --> (Tag "minimal wait after unstake" --> Empty + |+ Tag "wait longer after unstake" --> wait_n_cycles 2) + --> assert_failure + (check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> (Tag "finalize with finalize" --> finalize_unstake "staker" + |+ Tag "finalize with stake" --> stake "staker" (Amount Tez.one_mutez) + |+ Tag "finalize with unstake" --> unstake "staker" (Amount Tez.one_mutez) + ) + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero + +(* Test that an unstake operation doesn't cause finalization when + there are zero staked funds (so the unstake operation doesn't do + anything). *) +(* Todo: there might be other cases... like changing delegates *) +let scenario_not_finalize = + init_staker_delegate_or_external --> stake "staker" Half --> next_cycle + --> unstake "staker" All + --> wait_n_cycles_f (unstake_wait ++ 2) + --> assert_failure + (check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> snapshot_balances "not finalize" ["staker"] + --> (Tag "no finalize with unstake if staked = 0" + --> unstake "staker" (Amount Tez.one_mutez)) + --> assert_failure + (check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> check_snapshot_balances "not finalize" + +(* TODO: there's probably more... *) +let scenario_forbidden_operations = + let open Lwt_result_syntax in + let fail_if_staker_is_self_delegate staker = + exec (fun ((_, state) as input) -> + if State.(is_self_delegate staker state) then + failwith "_self_delegate_exit_" + else return input) + in + init_staker_delegate_or_external + --> (* Staking everything works for self delegates, but not for delegated accounts *) + assert_failure + (fail_if_staker_is_self_delegate "staker" --> stake "staker" All) + (* stake is always forbidden when amount is zero *) + --> assert_failure (stake "staker" Nothing) + (* One cannot stake more that one has *) + --> assert_failure (stake "staker" Max_tez) + (* unstake is actually authorized for amount 0, but does nothing (doesn't even finalize if possible) *) + --> unstake "staker" Nothing + +let full_balance_in_finalizable = + init_staker_delegate_or_external + --> add_account_with_funds + "dummy" + ~funder:"staker" + (Amount (Tez.of_mutez 10_000_000L)) + --> stake "staker" All_but_one --> next_cycle --> unstake "staker" All + --> wait_n_cycles_f (unstake_wait ++ 2) + (* At this point, almost all the balance (but one mutez) of the stake is in finalizable *) + (* Staking is possible, but not transfer *) + --> assert_failure + (transfer "staker" "dummy" (Amount (Tez.of_mutez 10_000_000L))) + --> stake "staker" (Amount (Tez.of_mutez 10_000_000L)) + (* After the stake, transfer is possible again because the funds were finalized *) + --> transfer "staker" "dummy" (Amount (Tez.of_mutez 10_000_000L)) + +(* Stress test: what happens if someone were to stake and unstake every cycle? *) +let odd_behavior = + init_staker_delegate_or_external + --> + let one_cycle = + no_tag --> stake "staker" Half --> unstake "staker" Half --> next_cycle + in + loop 20 one_cycle + +(* Test changing delegate to self delegation while having staked funds. *) +let change_delegate_to_self = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force --> begin_test ["delegate"] + --> set_delegate_params "delegate" init_params + --> add_account_with_funds + "staker" + ~funder:"delegate" + (Amount (Tez.of_mutez 2_000_000_000_000L)) + --> set_delegate "staker" (Some "delegate") + --> wait_delegate_parameters_activation --> stake "staker" Half --> next_cycle + --> set_delegate "staker" (Some "staker") + (* Can't stake: "A contract tries to stake to its delegate while + having unstake requests to a previous delegate that cannot be + finalized yet. Try again in a later cycle (no more than + consensus_rights_delay + max_slashing_period)." *) + --> assert_failure (stake "staker" Half) + --> unstake "staker" Max_tez + --> wait_n_cycles_f (unstake_wait -- 1) (* Still can't stake. *) + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero + --> assert_failure (stake "staker" Half) + --> next_cycle + (* The unstake request from changing delegates is now finalizable. *) + --> assert_failure + (check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> assert_success + (* Can directly stake again, which automatically finalizes, + even though the finalizable unstaked request is about a + previous delegate. *) + (stake "staker" Half + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> (Tag "finalize" + --> (* Explicitly finalize, so that we can check that the balances + are identical to the beginning. This proves that changing + delegates has indeed unstaked all staked funds. *) + finalize "staker" + --> check_snapshot_balances "init" + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero + |+ Tag "don't finalize" --> Empty) + --> stake "staker" Half --> unstake "staker" Half --> stake "staker" Half + +(* Test changing delegates while having staked funds. *) +let change_delegate = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> begin_test ["delegate1"; "delegate2"] + --> set_delegate_params "delegate1" init_params + --> set_delegate_params "delegate2" init_params + --> add_account_with_funds + "staker" + ~funder:"delegate1" + (Amount (Tez.of_mutez 2_000_000_000_000L)) + --> snapshot_balances "init" ["staker"] + --> set_delegate "staker" (Some "delegate1") + --> wait_delegate_parameters_activation --> stake "staker" Half + --> snapshot_balances "after_stake" ["staker"] + (* Changing delegates. This also unstakes all staked funds. *) + --> set_delegate "staker" (Some "delegate2") + (* Can't stake: "A contract tries to stake to its delegate while + having unstake requests to a previous delegate that cannot be + finalized yet. Try again in a later cycle (no more than + consensus_rights_delay + max_slashing_period)." *) + --> assert_failure (stake "staker" Half) + --> unstake "staker" Max_tez + --> wait_n_cycles_f (unstake_wait -- 1) (* Still can't stake. *) + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero + --> assert_failure (stake "staker" Half) + --> next_cycle + (* The unstake request from changing delegates is now finalizable. *) + --> assert_failure + (check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> assert_success + (* Can directly stake again, which automatically finalizes, + even though the finalizable unstaked request is about a + previous delegate. *) + (stake "staker" Half + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero) + --> (Tag "finalize" + --> (* Explicitly finalize, so that we can check that the balances + are identical to the beginning. This proves that changing + delegates has indeed unstaked all staked funds. *) + finalize "staker" + --> check_snapshot_balances "init" + --> check_balance_field "staker" `Unstaked_finalizable Tez.zero + --> (* Staking again is also possible. *) stake "staker" Half + --> check_snapshot_balances "after_stake" + |+ Tag "don't finalize" --> stake "staker" Half) + --> (Tag "finally, unstake" --> unstake "staker" Half + |+ Tag "finally, change delegate one last time" + --> set_delegate "staker" (Some "delegate1") + |+ Tag "finally, unset delegate" --> set_delegate "staker" None) + +let unset_delegate = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force --> begin_test ["delegate"] + --> set_delegate_params "delegate" init_params + --> add_account_with_funds + "staker" + ~funder:"delegate" + (Amount (Tez.of_mutez 2_000_000_000_000L)) + --> add_account_with_funds + "dummy" + ~funder:"delegate" + (Amount (Tez.of_mutez 2_000_000L)) + --> set_delegate "staker" (Some "delegate") + --> wait_delegate_parameters_activation --> stake "staker" Half + --> unstake "staker" All --> next_cycle --> set_delegate "staker" None + --> next_cycle + --> transfer "staker" "dummy" All + (* staker has an empty liquid balance, but still has unstaked frozen tokens, + so it doesn't get deactivated *) + --> wait_n_cycles_f (unstake_wait ++ 1) + --> finalize_unstake "staker" + +(* Test that external stakers cannot stake when a delegate sets the + limit of staking over baking to zero, then can stake again when the + limit is set back to one. Changes take effect only after + [delegate_parameters_activation_delay + 1] cycles. *) +let forbid_costaking = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + let no_costake_params = + {limit_of_staking_over_baking = Q.zero; edge_of_baking_over_staking = Q.one} + in + let amount = Amount (Tez.of_mutez 1_000_000L) in + (* init constants *) + (Tag "default protocol constants" --> init_constants () + |+ Tag "small delegate parameters delay" + --> init_constants ~delegate_parameters_activation_delay:0 () + |+ Tag "large delegate parameters delay" + --> init_constants ~delegate_parameters_activation_delay:10 ()) + (* Set flags *) + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Zero_threshold + (* Start scenario *) + --> begin_test ["delegate"] + --> set_delegate_params "delegate" init_params + --> add_account_with_funds + "staker" + ~funder:"delegate" + (Amount (Tez.of_mutez 2_000_000_000_000L)) + --> set_delegate "staker" (Some "delegate") + --> wait_cycle_until (`And (`AI_activation, `delegate_parameters_activation)) + (* try stake in normal conditions *) + --> stake "staker" amount + (* Change delegate parameters to forbid staking *) + --> set_delegate_params "delegate" no_costake_params + (* The changes are not immediate *) + --> stake "staker" amount + (* The parameters change is applied after at least + [delegate_parameters_activation_delay] full cycles have passed, + that is, exactly [delegate_parameters_activation_delay + 1] + cycles after the request. *) + --> wait_cycle_until `right_before_delegate_parameters_activation + (* Not yet... *) + --> stake "staker" amount + --> next_cycle + (* External staking is now forbidden *) + --> assert_failure (stake "staker" amount) + (* Can still self-stake *) + --> stake "delegate" amount + (* Can still unstake *) + --> unstake "staker" Half + --> wait_n_cycles_f (unstake_wait ++ 1) + --> finalize_unstake "staker" + (* Can authorize stake again *) + --> set_delegate_params "delegate" init_params + --> wait_cycle_until `right_before_delegate_parameters_activation + (* Not yet... *) + --> assert_failure (stake "staker" amount) + --> next_cycle + (* Now possible *) + --> stake "staker" amount + +(* Check that a delegate can be deactivated under AI by unstaking everything, even with stakers. + Check that such a delegate can reactivate later, and still have their stakers *) +let test_deactivation = + let init_params = + {limit_of_staking_over_baking = Q.one; edge_of_baking_over_staking = Q.one} + in + let fail_if_deactivated delegate = + let open Lwt_result_syntax in + exec_unit (fun (block, state) -> + let dlgt = State.find_account delegate state in + let* deactivated = Context.Delegate.deactivated (B block) dlgt.pkh in + Assert.is_true ~loc:__LOC__ (not deactivated)) + in + init_constants () + --> set S.Adaptive_issuance.autostaking_enable false + --> activate_ai `Force + --> begin_test ["delegate"; "faucet"] + --> stake "delegate" (Amount (Tez.of_mutez 1_800_000_000_000L)) + --> set_delegate_params "delegate" init_params + --> add_account_with_funds + "staker1" + ~funder:"faucet" + (Amount (Tez.of_mutez 200_000_000_000L)) + --> add_account_with_funds + "staker2" + ~funder:"faucet" + (Amount (Tez.of_mutez 200_000_000_000L)) + --> wait_delegate_parameters_activation + --> set_delegate "staker1" (Some "delegate") + --> set_delegate "staker2" (Some "delegate") + --> stake "staker1" Half --> stake "staker2" Half --> next_cycle + (* The delegate unstakes all, starting the deactivation process *) + --> unstake "delegate" All + (* "delegate" can still bake, but not for long... *) + --> assert_success ~loc:__LOC__ (next_block_with_baker "delegate") + --> wait_n_cycles_f (fun (_, state) -> + state.State.constants.consensus_rights_delay) + (* After consensus_rights_delay, the delegate still has rights... *) + --> assert_success ~loc:__LOC__ (next_block_with_baker "delegate") + --> next_cycle + (* ...But not in the following cycle *) + --> assert_failure ~loc:__LOC__ (next_block_with_baker "delegate") + (* The stakers still have stake, and can still stake/unstake *) + --> check_balance_field "staker1" `Staked (Tez.of_mutez 100_000_000_000L) + --> check_balance_field "staker2" `Staked (Tez.of_mutez 100_000_000_000L) + --> assert_success ~loc:__LOC__ (stake "staker1" Half) + --> assert_success + ~loc:__LOC__ + (unstake "staker2" Half --> wait_n_cycles 5 + --> finalize_unstake "staker2") + (* We wait until the delegate is completely deactivated *) + --> assert_success ~loc:__LOC__ (fail_if_deactivated "delegate") + (* We already waited for [consensus_rights_delay] + 1 cycles since 0 stake, + we must wait for [consensus_rights_delay] more. *) + --> wait_n_cycles_f (fun (_, state) -> + state.State.constants.consensus_rights_delay) + --> assert_success ~loc:__LOC__ (fail_if_deactivated "delegate") + --> next_cycle + --> assert_failure ~loc:__LOC__ (fail_if_deactivated "delegate") + --> next_cycle + (* The stakers still have stake, and can still stake/unstake *) + --> check_balance_field "staker1" `Staked (Tez.of_mutez 100_000_000_000L) + --> check_balance_field "staker2" `Staked (Tez.of_mutez 100_000_000_000L) + --> assert_success ~loc:__LOC__ (stake "staker1" Half) + --> assert_success + ~loc:__LOC__ + (unstake "staker2" Half --> wait_n_cycles 5 + --> finalize_unstake "staker2") + --> next_cycle + (* We now reactivate the delegate *) + --> set_delegate "delegate" (Some "delegate") + --> stake "delegate" (Amount (Tez.of_mutez 2_000_000_000_000L)) + (* It cannot bake right away *) + --> assert_failure ~loc:__LOC__ (next_block_with_baker "delegate") + --> wait_n_cycles_f (fun (_, state) -> + state.State.constants.consensus_rights_delay) + (* After consensus_rights_delay, the delegate still has no rights... *) + --> assert_failure ~loc:__LOC__ (next_block_with_baker "delegate") + --> next_cycle + (* ...But has enough to bake in the following cycle *) + --> assert_success ~loc:__LOC__ (next_block_with_baker "delegate") + --> exec_unit (fun (_, state) -> + let dlgt = State.find_account "delegate" state in + let total = Frozen_tez.total_current dlgt.frozen_deposits in + Assert.equal_tez ~loc:__LOC__ total (Tez.of_mutez 2_200_000_000_000L)) + +let tests = + tests_of_scenarios + @@ [ + ("Test simple roundtrip", simple_roundtrip); + ("Test double roundtrip", double_roundtrip); + ("Test preserved balance", status_quo_rountrip); + ("Test finalize", scenario_finalize); + ("Test no finalize", scenario_not_finalize); + ("Test forbidden operations", scenario_forbidden_operations); + ("Test full balance in finalizable", full_balance_in_finalizable); + ("Test stake unstake every cycle", odd_behavior); + ("Test change delegate", change_delegate); + ("Test change delegate to self", change_delegate_to_self); + ("Test unset delegate", unset_delegate); + ("Test forbid costake", forbid_costaking); + ("Test stake from unstake", shorter_roundtrip_for_baker); + ("Test deactivation under AI", test_deactivation); + ] + +let () = register_tests ~__FILE__ ~tags:["protocol"; "scenario"; "stake"] tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage.ml index cd9f59807a1e81dfc435d1c6595bd99a1bb4f6a7..e54ec5b71d1772d1af8019daa1c7e21ad91da88c 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage.ml @@ -35,6 +35,8 @@ open Protocol open Storage_functors open Storage_sigs +let register_test = Tezt_helpers.register_test ~__FILE__ ~file_tags:["storage"] + module Int32 = struct type t = int32 @@ -217,26 +219,16 @@ let test_register_indexed_subcontext_2 () = in must_failwith f_prog error -let tests = - [ - Alcotest_lwt.test_case - "register single data in existing path" - `Quick - (fun _ -> test_register_single_data); - Alcotest_lwt.test_case - "register named subcontext in existing path" - `Quick - (fun _ -> test_register_named_subcontext); - Alcotest_lwt.test_case - "register indexed subcontext in existing path" - `Quick - (fun _ -> test_register_indexed_subcontext); - Alcotest_lwt.test_case - "register indexed subcontext with existing indexed subcontext" - `Quick - (fun _ -> test_register_indexed_subcontext_2); - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("storage description", tests)] - |> Lwt_main.run + register_test + ~title:"register single data in existing path" + test_register_single_data ; + register_test + ~title:"register named subcontext in existing path" + test_register_named_subcontext ; + register_test + ~title:"register indexed subcontext in existing path" + test_register_indexed_subcontext ; + register_test + ~title:"register indexed subcontext with existing indexed subcontext" + test_register_indexed_subcontext_2 diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage_functions.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage_functions.ml index 426a3283a8e0392ba56f746024d92797d7c24edf..01ef50f93a831820282f140cb9e0ab2a2a09397f 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage_functions.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_storage_functions.ml @@ -34,6 +34,9 @@ open Protocol open Storage_functors +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["storage"] + let assert_length ~loc ctxt key expected = let open Lwt_result_syntax in let*! length = Raw_context.length ctxt key in @@ -218,23 +221,14 @@ let test_clear_carbonated_data_set () = let* () = Assert.equal_bool ~loc:__LOC__ is_empty0 true in Assert.equal_bool ~loc:__LOC__ is_empty1 false -let tests = - [ - Tztest.tztest - "fold_keys_unaccounted smoke test" - `Quick - test_fold_keys_unaccounted; - Tztest.tztest "length test" `Quick test_length; - Tztest.tztest - "test empty carbonated data set" - `Quick - test_is_empty_carbonated_data_set; - Tztest.tztest - "test clear carbonated data set" - `Quick - test_clear_carbonated_data_set; - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("storage tests", tests)] - |> Lwt_main.run + register_test + ~title:"fold_keys_unaccounted smoke test" + test_fold_keys_unaccounted ; + register_test ~title:"length test" test_length ; + register_test + ~title:"test empty carbonated data set" + test_is_empty_carbonated_data_set ; + register_test + ~title:"test clear carbonated data set" + test_clear_carbonated_data_set diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/test_token.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_token.ml index f39a533caabbf958a663427d2a22c9abe9937b5e..e20cf2a8dfc5a9332bc4f464bc7ff5ae33f8642e 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/test_token.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/test_token.ml @@ -33,7 +33,9 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers + +let register_test = Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["token"] (** Creates a context with a single account. Returns the context and the public key hash of the account. *) @@ -756,34 +758,22 @@ let test_transfer_n_with_several_givers () = in return_unit -let tests = - Tztest. - [ - tztest "transfer - balances" `Quick test_simple_balances; - tztest "transfer - balance updates" `Quick test_simple_balance_updates; - tztest "transfer - test allocated" `Quick test_allocated; - tztest - "transfer - test transfer to receiver" - `Quick - test_transferring_to_receiver; - tztest - "transfer - test transfer from giver" - `Quick - test_transferring_from_giver; - tztest - "transfer - test all (givers x receivers)" - `Quick - test_all_combinations_of_givers_and_receivers; - tztest - "transfer - test from no giver to a receiver" - `Quick - test_transfer_n_with_no_giver; - tztest - "transfer - test from n givers to a receiver" - `Quick - test_transfer_n_with_several_givers; - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("token movements", tests)] - |> Lwt_main.run + register_test ~title:"transfer - balances" test_simple_balances ; + register_test ~title:"transfer - balance updates" test_simple_balance_updates ; + register_test ~title:"transfer - test allocated" test_allocated ; + register_test + ~title:"transfer - test transfer to receiver" + test_transferring_to_receiver ; + register_test + ~title:"transfer - test transfer from giver" + test_transferring_from_giver ; + register_test + ~title:"transfer - test all (givers x receivers)" + test_all_combinations_of_givers_and_receivers ; + register_test + ~title:"transfer - test from no giver to a receiver" + test_transfer_n_with_no_giver ; + register_test + ~title:"transfer - test from n givers to a receiver" + test_transfer_n_with_several_givers diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/dune b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/dune index 38681f6c24b142c763214be77cc5d7751d475fae..fefb3bf80c8bfc5c3dc1438d7cf4f2ac4152b312 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/dune +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/dune @@ -6,7 +6,6 @@ (instrumentation (backend bisect_ppx)) (libraries tezt.core - octez-alcotezt octez-libs.base tezos-protocol-019-PtParisB.protocol qcheck-alcotest @@ -21,7 +20,6 @@ (:standard) -open Tezt_core -open Tezt_core.Base - -open Octez_alcotezt -open Tezos_base.TzPervasives -open Tezos_protocol_019_PtParisB -open Tezos_client_019_PtParisB diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 041cb34f2858efbf67a4cfb678e2fc8825968c96..bb4fea69493fcd7f64b2e363ad9ca25068fb8658 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -7,7 +7,7 @@ open Protocol open Alpha_context -open Test_tez +open Tez_helpers (** {2 Constants} *) @@ -992,35 +992,54 @@ let select_op (op_req : operation_req) (infos : infos) = in mk_op op_req infos -let make_tztest ?(fmt = Format.std_formatter) name test subjects info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> - let* infos = info_builder () in - List.iter_es - (fun kind -> - Format.fprintf fmt "%s: %s@." name (kind_to_string kind) ; - test infos kind) - subjects) - -let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects - info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> +let make_test + ~(register_test : + title:string -> + ?additional_tags:string trace -> + ?slow:bool -> + (unit -> (unit, tztrace) result Lwt.t) -> + unit) name test (subjects : manager_operation_kind list) info_builder = + List.iter + (fun kind -> + let title = Format.sprintf "%s: %s@." name (kind_to_string kind) in + register_test ~title @@ fun () -> + let open Lwt_syntax in let* infos = info_builder () in - List.iter_es - (fun kind1 -> - let k1s = kind_to_string kind1 in - List.iter_es - (fun kind2 -> - Format.fprintf - fmt - "%s: [%s ; %s]@." - name - k1s - (kind_to_string kind2) ; - test infos kind1 kind2) - subjects) + let infos = + match infos with + | Error errs -> + Tezt.Test.fail "Error: %a" Error_monad.pp_print_trace errs + | Ok infos -> infos + in + test infos kind) + subjects + +let make_test_batched + ~(register_test : + title:string -> + ?additional_tags:string trace -> + ?slow:bool -> + (unit -> (unit, tztrace) result Lwt.t) -> + unit) name test subjects info_builder = + List.iter + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter + (fun kind2 -> + let title = + Format.sprintf "%s: [%s ; %s]@." name k1s (kind_to_string kind2) + in + register_test ~title @@ fun () -> + let* infos = info_builder () in + let infos = + match infos with + | Error errs -> + Tezt.Test.fail "Error: %a" Error_monad.pp_print_trace errs + | Ok infos -> infos + in + test infos kind1 kind2) subjects) + subjects (** {2 Diagnostic helpers.} *) diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_1m_restriction.ml index 4e8ab578767ae1503a608d10bf3c102a3ab87d29..43d220772836c1641664d56bf6efdd81fd2dea7c 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -17,6 +17,11 @@ open Protocol open Manager_operation_helpers open Generators +let register_test = + Tezt_helpers.register_test + ~__FILE__ + ~file_tags:["1m"; "validation"; "operation"] + let count = 100 (** Local default values for the tests. *) @@ -208,6 +213,4 @@ let tests : (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) trace = conflict_free_tests; ] -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("one-manager restriction", tests)] - |> Lwt_main.run +let () = List.iter (fun (s, _, f) -> register_test ~title:s f) tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_covalidity.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_covalidity.ml index a3cc2c63fe9f05e19fe48ea342d0fd83ac918418..2632fc770f8f7e9f7265da9b07886f01487f9ebd 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_covalidity.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_covalidity.ml @@ -19,6 +19,9 @@ open Valid_operations_generators open Protocol open Alpha_context +let register_test = + Tezt_helpers.register_test ~__FILE__ ~file_tags:["validation"; "operation"] + (** Values of number of bootstraps to create.*) let default_nb_bootstrap = 7 @@ -137,6 +140,4 @@ let tests = voting_periods |> Qcheck2_helpers.qcheck_wrap_lwt -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("covalidity", tests)] - |> Lwt_main.run +let () = List.iter (fun (s, _, f) -> register_test ~title:s f) tests diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 376d519fe174f122a6c1d3f92782fb96f5171c48..fa3b48188a3614ee16d52cc7b5638ed09dba6c7d 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -17,6 +17,11 @@ open Protocol open Alpha_context open Manager_operation_helpers +let register_test = + Tezt_helpers.register_test_es + ~__FILE__ + ~file_tags:["validation"; "manager_operation"] + (** {2 Negative tests assert the case where validate must fail} *) (** Validate fails if the gas limit is too low. @@ -540,7 +545,7 @@ let test_feature_flags infos kind = let* (_ : infos) = validate_diagnostic infos [op] in return_unit -let tests = +let () = let mk_default () = default_init_ctxt () in let mk_reveal () = init_ctxt {ctxt_req_default with reveal_accounts = false} @@ -571,9 +576,9 @@ let tests = let gas_consum = gas_consumer_in_validate_subjects in let not_gas_consum = not_gas_consumer_in_validate_subjects in let revealed = revealed_subjects in - List.map + List.iter (fun (name, f, subjects, info_builder) -> - make_tztest name f subjects info_builder) + make_test ~register_test name f subjects info_builder) [ (* Expected validation failure *) ("gas limit too low", test_low_gas_limit, gas_consum, mk_default); @@ -610,10 +615,3 @@ let tests = mk_flags disabled_scoru_arith ); ("zkru disabled", test_feature_flags, all, mk_flags disabled_zkru); ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("single manager validation", tests)] - |> Lwt_main.run diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_mempool.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_mempool.ml index 1ed344ba12a98aae9b4b621f38437d144534df06..052fad4efc85ac8e68ef70bc4075109ec3f43102 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_mempool.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_mempool.ml @@ -35,6 +35,9 @@ open Protocol open Alpha_context module Mempool = Mempool_validation +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["validation"; "mempool"] + let extract_values ctxt (b : Block.t) = let predecessor_level = Level.from_raw ctxt (Raw_level.of_int32_exn b.header.shell.level) @@ -378,18 +381,14 @@ let test_remove_operation () = let empty_mempool = Mempool.remove_operation mempool (fst op1) in assert_empty_mempool ~__LOC__ empty_mempool -let tests = - [ - Tztest.tztest "simple" `Quick test_simple; - Tztest.tztest "incompatible mempool" `Quick test_imcompatible_mempool; - Tztest.tztest "merge" `Quick test_merge; - Tztest.tztest "adding invalid operation" `Quick test_add_invalid_operation; - Tztest.tztest - "adding operation with conflict handler" - `Quick - test_add_and_replace; - Tztest.tztest "remove operations" `Quick test_remove_operation; - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("mempool", tests)] |> Lwt_main.run + List.iter + (fun (title, f) -> register_test ~title f) + [ + ("simple", test_simple); + ("incompatible mempool", test_imcompatible_mempool); + ("merge", test_merge); + ("adding invalid operation", test_add_invalid_operation); + ("adding operation with conflict handler", test_add_and_replace); + ("remove operations", test_remove_operation); + ] diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_sanity.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_sanity.ml index 75ac0a523c8a22da554ff5832d0d2418bb5f96ba..17e103ef812f978eacecbdfd558cb57473af0244 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_sanity.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_sanity.ml @@ -17,6 +17,9 @@ open Protocol open Alpha_context open Manager_operation_helpers +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["validation"; "operation"] + (** The goal of this test is to ensure that [select_op] generate the wanted kind of manager operation @@ -134,14 +137,9 @@ let covalidation_sanity () = | Single (Failing_noop _), _ -> assert false)) all_kinds -let tests = - List.map - (fun (name, f) -> Tztest.tztest name `Quick f) - [ - ("manager operation coverage", ensure_manager_operation_coverage); - ("covalidation coverage", covalidation_sanity); - ] - let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sanity checks", tests)] - |> Lwt_main.run + register_test + ~title:"manager operation coverage" + ensure_manager_operation_coverage + +let () = register_test ~title:"covalidation coverage" covalidation_sanity diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_validation_batch.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_validation_batch.ml index 9501414844558eaea55cc754cf1c44fde92bc48a..e4788463d16fa7813df9f705cf2b44361ca12671 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_validation_batch.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/test_validation_batch.ml @@ -11,32 +11,24 @@ Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/integration/validate/main.exe \ -- --file test_validation_batch.ml Subject: Validation of batched manager operation. + + There may be overlap with + [lib_protocol/test/integration/operations/test_combined_operations.ml]. *) open Protocol open Alpha_context open Manager_operation_helpers +open Error_helpers -(** {2 Tests on operation batches} *) +let register_test = + Tezt_helpers.register_test_es ~__FILE__ ~file_tags:["validation"; "batch"] -(** Revelation should not occur elsewhere than in first position - in a batch.*) -let batch_reveal_in_the_middle_diagnostic (infos : infos) op = - let open Lwt_result_syntax in - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure +let make_test = make_test ~register_test + +let make_test_batched = make_test_batched ~register_test + +(** {2 Tests on operation batches} *) let batch_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in @@ -82,25 +74,8 @@ let batch_in_the_middle infos kind1 kind2 = (Context.B infos.ctxt.block) [operation1; reveal; operation2] in - batch_reveal_in_the_middle_diagnostic infos [batch] - -(** A batch of manager operation contains at most one Revelation.*) -let batch_two_reveals_diagnostic (infos : infos) op = - let open Lwt_result_syntax in - let expected_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expected_failure + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in + validate_ko_diagnostic infos [batch] expect_failure let batch_two_reveals infos kind = let open Lwt_result_syntax in @@ -146,23 +121,8 @@ let batch_two_reveals infos kind = (Context.B infos.ctxt.block) [reveal; reveal1; operation] in - batch_two_reveals_diagnostic infos [batch] - -(** Every manager operation in a batch concerns the same source.*) -let batch_two_sources_diagnostic (infos : infos) op = - let open Lwt_result_syntax in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Validate_errors.Manager.Inconsistent_sources] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure + let expect_failure = expect_incorrect_reveal_position ~loc:__LOC__ in + validate_ko_diagnostic infos [batch] expect_failure let batch_two_sources infos kind1 kind2 = let open Lwt_result_syntax in @@ -178,10 +138,10 @@ let batch_two_sources infos kind1 kind2 = } infos in + let source2 = + match infos.accounts.del with None -> assert false | Some s -> s + in let infos = - let source2 = - match infos.accounts.del with None -> assert false | Some s -> s - in {infos with accounts = {infos.accounts with sources = [source2]}} in let* operation2 = @@ -196,7 +156,13 @@ let batch_two_sources infos kind1 kind2 = (Context.B infos.ctxt.block) [operation1; operation2] in - batch_two_sources_diagnostic infos [batch] + let expect_failure = + Error_helpers.expect_inconsistent_sources + ~loc:__LOC__ + ~first_source:source + ~source:(contract_of source2) + in + validate_ko_diagnostic infos [batch] expect_failure (** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) @@ -270,34 +236,54 @@ let batch_incons_counters infos kind1 kind2 = (Context.B infos.ctxt.block) [reveal; op1; op2] in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Validate_errors.Manager.Inconsistent_counters] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in let* i = Incremental.begin_construction infos.ctxt.block in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_same - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_in_the_future - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_missing_one - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_inverse - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_in_the_past - in - return_unit + let test_inconsistent_counters ~__LOC__ ~before_wrong_counter ~wrong_counter + op = + let expect_failure = + (* Remember that [select_op] actually builds an operation + using the successor of the counter argument. *) + Error_helpers.expect_inconsistent_counters + ~loc:__LOC__ + ~source + ~previous_counter:(Manager_counter.succ before_wrong_counter) + ~counter:(Manager_counter.succ wrong_counter) + in + let* (_ : Incremental.t) = Incremental.add_operation ~expect_failure i op in + return_unit + in + let* () = + test_inconsistent_counters + ~__LOC__ + ~before_wrong_counter:counter + ~wrong_counter:counter + batch_same + in + let* () = + test_inconsistent_counters + ~__LOC__ + ~before_wrong_counter:counter0 + ~wrong_counter:counter2 + batch_in_the_future + in + let* () = + test_inconsistent_counters + ~__LOC__ + ~before_wrong_counter:counter + ~wrong_counter:counter3 + batch_missing_one + in + let* () = + test_inconsistent_counters + ~__LOC__ + ~before_wrong_counter:counter0 + ~wrong_counter:counter2 + batch_inverse + in + test_inconsistent_counters + ~__LOC__ + ~before_wrong_counter:counter0 + ~wrong_counter:counter0 + batch_in_the_past (** A batch that consumes all the balance for fees can only face the total consumption at the end of the batch. *) @@ -367,7 +353,7 @@ let batch_empty_at_end infos kind1 kind2 = let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in - let half_init_bal = Test_tez.(init_bal /! 2L) in + let half_init_bal = Tez_helpers.(init_bal /! 2L) in let* reveal = mk_reveal {(operation_req_default K_Reveal) with counter = Some counter} @@ -546,70 +532,44 @@ let batch_exceeding_block_gas ~mempool_mode infos kind1 kind2 = in return_unit -let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects - info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> - let* infos = info_builder () in - List.iter_es - (fun kind1 -> - let k1s = kind_to_string kind1 in - List.iter_es - (fun kind2 -> - Format.fprintf - fmt - "%s: [%s ; %s]@." - name - k1s - (kind_to_string kind2) ; - test infos kind1 kind2) - subjects) - subjects) - -let tests = - let open Lwt_result_syntax in +let () = let mk_default () = default_init_ctxt () in let mk_high_gas_limit () = init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} in let revealed = revealed_subjects in - [ - ( Tztest.tztest "batch reveal and transaction" `Quick @@ fun () -> - let* infos = mk_default () in - batch_reveal_transaction infos ); - ] - @ List.map - (fun (name, f, subjects, info_builder) -> - make_tztest name f subjects info_builder) - [("batch two reveals", batch_two_reveals, revealed, mk_default)] - @ List.map - (fun (name, f, subjects, info_builder) -> - make_tztest_batched name f subjects info_builder) - [ - ("reveal in the middle", batch_in_the_middle, revealed, mk_default); - ("batch two sources", batch_two_sources, revealed, mk_default); - ("batch incons. counters", batch_incons_counters, revealed, mk_default); - ( "empty balance in middle of batch", - batch_emptying_balance_in_the_middle, - revealed, - mk_default ); - ( "empty balance at end of batch", - batch_empty_at_end, - revealed, - mk_default ); - ( "too much gas consumption", - batch_exceeding_block_gas ~mempool_mode:false, - revealed, - mk_high_gas_limit ); - ( "too much gas consumption (mempool)", - batch_exceeding_block_gas ~mempool_mode:true, - revealed, - mk_high_gas_limit ); - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("batched managers validation", tests)] - |> Lwt_main.run + let () = + register_test ~title:"batch reveal and transaction" @@ fun () -> + let* infos = default_init_ctxt () in + let infos = + match infos with + | Error errs -> Tezt.Test.fail "Error: %a" Error_monad.pp_print_trace errs + | Ok infos -> infos + in + batch_reveal_transaction infos + in + List.iter + (fun (name, f, subjects, info_builder) -> + make_test name f subjects info_builder) + [("batch two reveals", batch_two_reveals, revealed, mk_default)] ; + List.iter + (fun (name, f, subjects, info_builder) -> + make_test_batched name f subjects info_builder) + [ + ("reveal in the middle", batch_in_the_middle, revealed, mk_default); + ("batch two sources", batch_two_sources, revealed, mk_default); + ("batch incons. counters", batch_incons_counters, revealed, mk_default); + ( "empty balance in middle of batch", + batch_emptying_balance_in_the_middle, + revealed, + mk_default ); + ("empty balance at end of batch", batch_empty_at_end, revealed, mk_default); + ( "too much gas consumption", + batch_exceeding_block_gas ~mempool_mode:false, + revealed, + mk_high_gas_limit ); + ( "too much gas consumption (mempool)", + batch_exceeding_block_gas ~mempool_mode:true, + revealed, + mk_high_gas_limit ); + ] diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/valid_operations_generators.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/valid_operations_generators.ml index 34b5a89f933cb31824d259502426b78f73e6e638..488e0a2142074b5a189a3506584b40fe9eb80186 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/valid_operations_generators.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/valid_operations_generators.ml @@ -107,6 +107,15 @@ let initiated_params descrs nb_accounts = Context.default_test_constants with consensus_threshold = 0; consensus_committee_size; + dal = + { + Context.default_test_constants.dal with + cryptobox_parameters = + { + Context.default_test_constants.dal.cryptobox_parameters with + number_of_shards = consensus_committee_size; + }; + }; } in let descrs_params = List.map (fun descr -> descr.parameters) descrs in diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/validate_helpers.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/validate_helpers.ml index f0bfa891c963634b4819d88d385aead151531b63..3b46a81c6d8cea65df377af22ac7e15957119200 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/integration/validate/validate_helpers.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/integration/validate/validate_helpers.ml @@ -94,7 +94,7 @@ type secret_account = { } let secrets = - (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) + (* Exported from proto_019_PtParisB client - TODO : remove when relocated to lib_crypto *) let read_key mnemonic email password = match Tezos_client_base.Bip39.of_words mnemonic with | None -> assert false diff --git a/src/proto_019_PtParisB/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_019_PtParisB/lib_protocol/test/pbt/test_tez_repr.ml index 9648a6ff2aa1fc540d303cb4d1dc5f19b345a2a9..8be5c0f97de5722bdebf9f83041dcdb15e5449db 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/pbt/test_tez_repr.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/pbt/test_tez_repr.ml @@ -32,7 +32,7 @@ *) open Protocol.Alpha_context -open Test_tez +open Tez_helpers let z_mutez_min = Z.zero diff --git a/src/proto_019_PtParisB/lib_protocol/test/regression/test_logging.ml b/src/proto_019_PtParisB/lib_protocol/test/regression/test_logging.ml index 770c856d8255015a310122193f78eb57e23fa890..6426f0f6c181bd079a35feb6dbe9edb395cc1017 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/regression/test_logging.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/regression/test_logging.ml @@ -207,7 +207,11 @@ let run_script transaction () = let* parameter, ctxt = match transaction with | With_lib {lib = {filename; storage}; parameter; _} -> - let* block, baker, _contract, _src2 = Contract_helpers.init () in + let* block, baker, _contract, _src2 = + Contract_helpers.init + ~hard_gas_limit_per_block:(Gas.Arith.integral_of_int_exn 10_000_000) + () + in let sender = Contract.Implicit baker in let* src_addr, _script, block = Contract_helpers.originate_contract_from_string_hash @@ -378,11 +382,11 @@ let () = ~storage:"{}" "spawn_identities"; transaction - ~parameter:"Pair \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" 17 3" + ~parameter:"Ticket \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" nat 17 3" ~storage:"None" "ticket_join"; transaction - ~parameter:"Pair \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" 17 3" + ~parameter:"Ticket \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" nat 17 3" ~storage:"Unit" "ticket_split"; transaction ~parameter:"5" ~storage:"3" "view_toplevel_lib"; diff --git a/src/proto_019_PtParisB/lib_protocol/test/unit/dune b/src/proto_019_PtParisB/lib_protocol/test/unit/dune index e2feaa3594886477fdb8e6226dd164a086b31994..52ad724c304b490cf665c33651c17e2ad072ce07 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/unit/dune +++ b/src/proto_019_PtParisB/lib_protocol/test/unit/dune @@ -73,7 +73,9 @@ test_dal_slot_proof test_adaptive_issuance test_adaptive_issuance_ema - test_percentage)) + test_percentage + test_full_staking_balance_repr + test_slashing_percentage)) (executable (name main) diff --git a/src/proto_019_PtParisB/lib_protocol/test/unit/test_adaptive_issuance.ml b/src/proto_019_PtParisB/lib_protocol/test/unit/test_adaptive_issuance.ml index 3767520c9e0078c056401cd9649c14402aadfc1c..d12171c5cf8212ccdc5c48766f1bc1ad3ab3ffbe 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/unit/test_adaptive_issuance.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/unit/test_adaptive_issuance.ml @@ -48,7 +48,7 @@ let test_reward_coefficient () = csts ~reward_kind:Baking_reward_fixed_portion) in - Assert.equal_tez ~loc:__LOC__ Test_tez.(default *! 4L) default_times_4 + Assert.equal_tez ~loc:__LOC__ Tez_helpers.(default *! 4L) default_times_4 let test_reward_coeff_ratio () = let open Delegate.Rewards.Internal_for_tests in diff --git a/src/proto_019_PtParisB/lib_protocol/test/unit/test_round_repr.ml b/src/proto_019_PtParisB/lib_protocol/test/unit/test_round_repr.ml index 4a1ed1d2752b432e8587a4118493736716b57d0c..5081f8a16321c0d910aa3973cbfe92e25fdc0ea5 100644 --- a/src/proto_019_PtParisB/lib_protocol/test/unit/test_round_repr.ml +++ b/src/proto_019_PtParisB/lib_protocol/test/unit/test_round_repr.ml @@ -39,9 +39,19 @@ type round_test = { round_duration : (int * int) list; (* input: level offset; output: round, round offset *) round_and_offset : (int * (int * int)) list; - (* input: pred_ts, pred_round, round; output: ts *) + (* + input: pred_ts, pred_round, round; output: ts + Given the timestamp [pred_ts] and round [pred_round] of the block + from the previous level, the starting timestamp of the [round] + at the current level is [ts]. + *) timestamp_of_round : ((int * int * int) * int) list; - (* input: pred_ts, pred_round, ts; output: round *) + (* + input: pred_ts, pred_round, ts; output: round + Given the timestamp [pred_ts] and round [pred_round] of the block + from the previous level, the round which starts at timestamp + [ts] is [round]. + *) round_of_timestamp : ((int * int * int) * int) list; } @@ -64,18 +74,37 @@ let case_3_4 = timestamp_of_round = [((100, 0, 6), 136); ((100, 1, 6), 137)]; round_of_timestamp = [ + ((100, 0, 103), 0); + ((100, 0, 105), 0); + ((100, 0, 106), 1); + ((100, 0, 109), 1); + ((100, 0, 110), 2); + ((100, 0, 114), 2); + ((100, 0, 115), 3); + ((100, 0, 120), 3); ((100, 0, 121), 4); ((100, 0, 122), 4); ((100, 0, 123), 4); ((100, 0, 124), 4); ((100, 0, 125), 4); ((100, 0, 126), 4); + ((100, 0, 127), 4); + ((100, 0, 128), 5); + ((100, 1, 104), 0); + ((100, 1, 106), 0); + ((100, 1, 107), 1); + ((100, 1, 110), 1); + ((100, 1, 111), 2); + ((100, 1, 115), 2); + ((100, 1, 116), 3); ((100, 1, 121), 3); ((100, 1, 122), 4); ((100, 1, 123), 4); ((100, 1, 124), 4); ((100, 1, 125), 4); ((100, 1, 126), 4); + ((100, 1, 128), 4); + ((100, 1, 129), 5); ]; } diff --git a/src/proto_019_PtParisB/lib_protocol/test/unit/test_slashing_percentage.ml b/src/proto_019_PtParisB/lib_protocol/test/unit/test_slashing_percentage.ml new file mode 100644 index 0000000000000000000000000000000000000000..6fbd40779140721d8d02494a7b8c6d37f35a572b --- /dev/null +++ b/src/proto_019_PtParisB/lib_protocol/test/unit/test_slashing_percentage.ml @@ -0,0 +1,194 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2024 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (quantities) + Invocation: dune exec src/proto_019_PtParisB/lib_protocol/test/unit/main.exe \ + -- --file test_slashing_percentage.ml + Subject: On slashing double attestations. +*) + +open Protocol + +let assert_equal ~loc pct1 pct2 = + let open Lwt_result_syntax in + let* pct1 in + let* pct2 in + let pct1_q = Percentage.to_q pct1 in + let pct2_q = Percentage.to_q pct2 in + Assert.equal_q ~loc pct1_q pct2_q + +let assert_equal_int ~loc n (pct : Percentage.t tzresult Lwt.t) = + let open Lwt_result_syntax in + let* pct in + let pct_q = Percentage.to_q pct in + Assert.equal_q ~loc Q.(n // 100) pct_q + +let assert_not_equal_int ~loc n (pct : Percentage.t tzresult Lwt.t) = + let open Lwt_result_syntax in + let* pct in + let pct_q = Percentage.to_q pct in + Assert.not_equal ~loc Q.equal "Values are equal" Q.pp_print Q.(n // 100) pct_q + +let raw_context ~max_slashing_threshold ~max_slashing_per_block ~ns_enable () = + let open Constants_helpers in + let constants = + Default_parameters.constants_test + |> Set.Adaptive_issuance.force_activation true + |> Set.Adaptive_issuance.ns_enable ns_enable + |> Set.max_slashing_threshold max_slashing_threshold + |> Set.max_slashing_per_block max_slashing_per_block + in + Context.raw_context_from_constants constants + +let make_fake_culprits_with_rights_from_int_list il = + let open Result_syntax in + let n = List.length il in + let* accounts_list = Account.generate_accounts n in + let pkh_list = List.map (fun x -> x.Account.pkh) accounts_list in + let pkh_rights_list = Stdlib.List.combine pkh_list il in + let map = + List.fold_left + (fun map (pkh, rights) -> + Environment.Signature.Public_key_hash.Map.add pkh rights map) + Environment.Signature.Public_key_hash.Map.empty + pkh_rights_list + in + return (map, pkh_list) + +let get_pct ~ns_enable ~max_slashing_threshold ~max_slashing_per_block int_list + = + let open Lwt_result_syntax in + let* ctxt = + raw_context ~max_slashing_threshold ~max_slashing_per_block ~ns_enable () + in + let*? map, pkh_list = make_fake_culprits_with_rights_from_int_list int_list in + return + @@ Protocol.Slash_percentage.Internal_for_tests.for_double_attestation + ctxt + map + pkh_list + +(** Test the double attesting slash is always 50% with ns_enable = false *) +let test_ns_enable_disable () = + let open Lwt_result_syntax in + let f x = + get_pct + ~ns_enable:false + ~max_slashing_threshold:100 + ~max_slashing_per_block:Percentage.p100 + [x] + in + let* () = assert_equal_int ~loc:__LOC__ 50 (f 0) in + let* () = assert_equal_int ~loc:__LOC__ 50 (f 1) in + let* () = assert_equal_int ~loc:__LOC__ 50 (f 100) in + let* () = assert_equal_int ~loc:__LOC__ 50 (f 10000) in + return_unit + +(** We set ns_enable = true for the following tests *) +let get_pct = get_pct ~ns_enable:true + +(** Tests that the slashing amount for several delegates is the same as long + as the sum of their rights is the same *) +let test_list_and_sum () = + let open Lwt_result_syntax in + (* A max slashing threshold of 100 ensures that x -> f [x] is injective *) + let f x = + get_pct + ~max_slashing_threshold:100 + ~max_slashing_per_block:Percentage.p100 + x + in + let* () = assert_equal ~loc:__LOC__ (f [0; 0]) (f [0]) in + let* () = assert_equal ~loc:__LOC__ (f [1; 2; 3]) (f [3; 3]) in + let* () = assert_equal ~loc:__LOC__ (f [120]) (f [60; 60; 0]) in + let* () = assert_equal ~loc:__LOC__ (f []) (f [0]) in + return_unit + +(** We test only one slashed delegate from now on *) +let get_pct i = get_pct [i] + +(** Tests the max_slashing_per_block parameter *) +let test_max_slashing_per_block () = + let open Lwt_result_syntax in + let f max_slash x = + let max_slashing_per_block = + Percentage.of_q_bounded ~round:`Up Q.(max_slash // 100) + in + get_pct ~max_slashing_threshold:100 ~max_slashing_per_block x + in + let* () = assert_equal_int ~loc:__LOC__ 100 (f 100 200) in + let* () = assert_equal_int ~loc:__LOC__ 1 (f 1 200) in + let* () = assert_equal_int ~loc:__LOC__ 49 (f 49 200) in + let* () = assert_equal_int ~loc:__LOC__ 100 (f 100 100) in + let* () = assert_not_equal_int ~loc:__LOC__ 100 (f 100 99) in + return_unit + +(** We now test with max slashing to 100% (mainnet value) *) +let get_pct = + get_pct + ~max_slashing_per_block: + Default_parameters.constants_mainnet.max_slashing_per_block + +(** Tests the max_slashing_threshold parameter *) +let test_max_slashing_threshold () = + let open Lwt_result_syntax in + let f max_slashing_threshold x = get_pct ~max_slashing_threshold x in + let* () = assert_equal_int ~loc:__LOC__ 100 (f 100 20000) in + let* () = assert_equal_int ~loc:__LOC__ 100 (f 1000 1001) in + let* () = assert_equal_int ~loc:__LOC__ 100 (f 1000 1000) in + let* () = assert_not_equal_int ~loc:__LOC__ 100 (f 1000 999) in + return_unit + +(** We now test with max slashing threshold to 2334 (mainnet value) *) +let get_pct = + get_pct + ~max_slashing_threshold: + Default_parameters.constants_mainnet.max_slashing_threshold + +(** Test slashing values for mainnet constants *) +let test_mainnet_values () = + let open Lwt_result_syntax in + let f x = get_pct x in + (* percentage with two decimals *) + let assert_equal_precise_int ~loc n (pct : Percentage.t tzresult Lwt.t) = + let open Lwt_result_syntax in + let* pct in + let pct_q = Percentage.to_q pct in + Assert.equal_q ~loc Q.(n // 10000) pct_q + in + let* () = assert_equal_precise_int ~loc:__LOC__ 0 (f 0) in + (* For 1 right, up to 23, slash is 0.01% *) + let* () = assert_equal_precise_int ~loc:__LOC__ 1 (f 1) in + let* () = assert_equal_precise_int ~loc:__LOC__ 1 (f 23) in + let* () = assert_equal_precise_int ~loc:__LOC__ 2 (f 24) in + (* Some random value points *) + let* () = assert_equal_precise_int ~loc:__LOC__ 19 (f 100) in + let* () = assert_equal_precise_int ~loc:__LOC__ 459 (f 500) in + let* () = assert_equal_precise_int ~loc:__LOC__ 1836 (f 1000) in + (* Highest non-saturated slash is 99.92% *) + let* () = assert_equal_precise_int ~loc:__LOC__ 9983 (f 2332) in + let* () = assert_equal_precise_int ~loc:__LOC__ 9992 (f 2333) in + let* () = assert_equal_precise_int ~loc:__LOC__ 10000 (f 2334) in + let* () = assert_equal_precise_int ~loc:__LOC__ 10000 (f 7000) in + let* () = assert_equal_precise_int ~loc:__LOC__ 10000 (f 70000) in + return_unit + +let tests = + Tztest. + [ + tztest "Test ns_enable = false" `Quick test_ns_enable_disable; + tztest "Test only sum of rights counts" `Quick test_list_and_sum; + tztest "Test max_slashing_per_block" `Quick test_max_slashing_per_block; + tztest "Test max_slashing_threshold" `Quick test_max_slashing_threshold; + tztest "Test exact slashing values" `Quick test_mainnet_values; + ] + +let () = + Alcotest_lwt.run ~__FILE__ Protocol.name [("slashing_percentage", tests)] + |> Lwt_main.run