From a5951e4ba426a0993362994d9792598173159fca Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 14:25:42 +0200 Subject: [PATCH 1/8] Proto/tests: update build rules This change is pretty straightforward: in lib_protocol/test, anything for 020 is activated for 019, and anything for 019 and not for 020 is removed for 019. The exception to this is test_host_operation in integration/operations, because it requires the implementation of the HOST operation, which is not in Paris. Also we update the README, and expose a RPC in the plugin for the tests (I'm not doing a separate commit for that) --- manifest/product_octez.ml | 29 +++++++++---------- opam/octez-protocol-019-PtParisB-libs.opam | 3 +- opam/tezos-protocol-019-PtParisB-tests.opam | 2 +- src/proto_019_PtParisB/lib_plugin/RPC.ml | 3 ++ .../lib_protocol/test/README.md | 2 +- 5 files changed, 20 insertions(+), 19 deletions(-) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 1c07bb08ee72..d47b0369d0d3 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 e8b020715d40..4e60e55be982 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 816606d00525..bcbabddee90d 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 402c8cdf2a4c..54b63db54436 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 d938f4e7cb3d..6e7e33a67ec0 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. -- GitLab From 036a35bee11dd5ac17e9213f08f6390932868a86 Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 14:34:59 +0200 Subject: [PATCH 2/8] Proto/tests: backport test helpers to ParisB Actually pretty straightforward. It's mostly indentical to alpha, except that we remove anything related to sponsored operations. Also rename test_tez.ml. --- .../test/helpers/account_helpers.ml | 546 ++++++++ .../test/helpers/adaptive_issuance_helpers.ml | 1210 +---------------- .../lib_protocol/test/helpers/assert.ml | 45 + .../lib_protocol/test/helpers/block.ml | 37 +- .../lib_protocol/test/helpers/block.mli | 4 +- .../test/helpers/constants_helpers.ml | 194 +++ .../lib_protocol/test/helpers/context.ml | 28 +- .../lib_protocol/test/helpers/context.mli | 24 +- .../test/helpers/contract_helpers.ml | 10 +- .../lib_protocol/test/helpers/cpmm_logic.ml | 2 +- .../lib_protocol/test/helpers/dal_helpers.ml | 12 +- .../lib_protocol/test/helpers/dune | 5 +- .../test/helpers/error_helpers.ml | 59 + .../lib_protocol/test/helpers/log_helpers.ml | 22 + .../lib_protocol/test/helpers/op.ml | 2 +- .../test/helpers/sapling_helpers.ml | 4 +- .../lib_protocol/test/helpers/scenario.ml | 17 + .../test/helpers/scenario_bake.ml | 555 ++++++++ .../test/helpers/scenario_base.ml | 268 ++++ .../test/helpers/scenario_begin.ml | 191 +++ .../test/helpers/scenario_constants.ml | 50 + .../lib_protocol/test/helpers/scenario_dsl.ml | 203 +++ .../lib_protocol/test/helpers/scenario_op.ml | 604 ++++++++ .../test/helpers/slashing_helpers.ml | 275 ++++ .../test/helpers/slashing_helpers.mli | 55 + .../lib_protocol/test/helpers/state.ml | 202 +++ .../test/helpers/state_account.ml | 427 ++++++ .../test/helpers/state_ai_flags.ml | 289 ++++ .../test/helpers/state_ai_flags.mli | 80 ++ .../helpers/{test_tez.ml => tez_helpers.ml} | 58 +- .../lib_protocol/test/helpers/tez_helpers.mli | 89 ++ .../test/helpers/tez_staking_helpers.ml | 567 ++++++++ .../lib_protocol/test/helpers/tezt_helpers.ml | 38 + .../lib_protocol/test/helpers/transfers.ml | 2 +- 34 files changed, 4932 insertions(+), 1242 deletions(-) create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/account_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/constants_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/error_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/log_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_bake.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_base.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_begin.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_constants.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_dsl.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/scenario_op.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/slashing_helpers.mli create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/state.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/state_account.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/state_ai_flags.mli rename src/proto_019_PtParisB/lib_protocol/test/helpers/{test_tez.ml => tez_helpers.ml} (68%) create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/tez_helpers.mli create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/tez_staking_helpers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/helpers/tezt_helpers.ml 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 000000000000..2378e47d5322 --- /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 504bb7859556..111fc53c73d7 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 9f42a9e2ec7c..2e00f89b65d6 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 bace2e618fd6..f40e9af073e0 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 02fe3efa0ec7..401382c096eb 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 000000000000..bb06992ed0e0 --- /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 77bbac4a3b8c..8709a4659a44 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 c6593218e140..3965942511b7 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 32043ee302b7..56b5cb458694 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 a1d4d8027c58..3b50ed17945e 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 09dffdb09ad0..847bbc2046f9 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 6167b19c955f..cb945491ad26 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 000000000000..34c08aecfe95 --- /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 000000000000..af59306b9dd1 --- /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 b1ee1cdb0441..7a625f8c4bc8 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 5e058258d5e1..25100ebcb406 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 000000000000..38a2e0be669a --- /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 000000000000..356b65fb4e86 --- /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 000000000000..ddcbe5f97282 --- /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 000000000000..6ea7a016fc18 --- /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 000000000000..019dbb46bd08 --- /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 000000000000..4c85caa40300 --- /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 000000000000..d12946b258bc --- /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 000000000000..4de8fb8d3776 --- /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 000000000000..106d5c250cd4 --- /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 000000000000..6e245b1d77ca --- /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 000000000000..16bf5d2dba7c --- /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 000000000000..40fce015234a --- /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 000000000000..af1808d26400 --- /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 7d523a82c98e..1be51c6b3a1e 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 000000000000..57d5501364ef --- /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 000000000000..141a2c17c80a --- /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 000000000000..e075dbbca559 --- /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 f04fab9a7c8e..864b70be878a 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 = -- GitLab From 29fc14420dd83fcdbb8e84da5e013c54b57b500c Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 14:48:35 +0200 Subject: [PATCH 3/8] Proto/tests: backport integration (root) tests Unchanged from alpha, except test_scenario_slashing_stakers.ml, in which we change the last allowed cycle for the validation erorr on late denunciation inclusion. This is because this was changed in alpha in the protocol. Only the return value of the error was changed (see Outdated_denunciation in validate.ml). --- .../lib_protocol/test/integration/dune | 10 +- .../test_adaptive_issuance_launch.ml | 86 +- .../test_adaptive_issuance_roundtrip.ml | 2952 ----------------- .../test/integration/test_constants.ml | 62 +- .../test/integration/test_frozen_bonds.ml | 96 +- .../test/integration/test_liquidity_baking.ml | 223 +- .../integration/test_scenario_autostaking.ml | 254 ++ .../test/integration/test_scenario_base.ml | 33 + .../integration/test_scenario_deactivation.ml | 158 + .../test/integration/test_scenario_rewards.ml | 367 ++ .../integration/test_scenario_slashing.ml | 386 +++ .../test_scenario_slashing_stakers.ml | 193 ++ .../test/integration/test_scenario_stake.ml | 596 ++++ .../test/integration/test_storage.ml | 36 +- .../integration/test_storage_functions.ml | 32 +- .../test/integration/test_token.ml | 52 +- 16 files changed, 2229 insertions(+), 3307 deletions(-) delete mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_roundtrip.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_autostaking.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_base.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_deactivation.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_rewards.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_slashing_stakers.ml create mode 100644 src/proto_019_PtParisB/lib_protocol/test/integration/test_scenario_stake.ml diff --git a/src/proto_019_PtParisB/lib_protocol/test/integration/dune b/src/proto_019_PtParisB/lib_protocol/test/integration/dune index 9b34e6bcb253..afbf2c09b900 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/test_adaptive_issuance_launch.ml b/src/proto_019_PtParisB/lib_protocol/test/integration/test_adaptive_issuance_launch.ml index dd3e4a6d9895..5a8e715fbb05 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 49eefd7e4e3b..000000000000 --- 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 ee7a4a4792e5..0c03f3a90d3a 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 dc235af2c07e..c44d8e7f68e6 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 6935e2dc190c..0cd3ab6a6f3e 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 000000000000..734babdeb1d3 --- /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 000000000000..58199ed65c1a --- /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 000000000000..764d09bfbe68 --- /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 000000000000..25827edc4311 --- /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 000000000000..3cdedd52d8d5 --- /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 000000000000..5d87e7d267bd --- /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 000000000000..d631f74f5b84 --- /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 cd9f59807a1e..e54ec5b71d17 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 426a3283a8e0..01ef50f93a83 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 f39a533caabb..e20cf2a8dfc5 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 -- GitLab From 214ebcd98d210b0873ff83c81c538b46bee45113 Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 14:55:46 +0200 Subject: [PATCH 4/8] Proto/tests: backport unit tests Slashing percentage unit tests are added --- .../lib_protocol/test/unit/dune | 4 +- .../test/unit/test_adaptive_issuance.ml | 2 +- .../lib_protocol/test/unit/test_round_repr.ml | 33 ++- .../test/unit/test_slashing_percentage.ml | 194 ++++++++++++++++++ 4 files changed, 229 insertions(+), 4 deletions(-) create mode 100644 src/proto_019_PtParisB/lib_protocol/test/unit/test_slashing_percentage.ml diff --git a/src/proto_019_PtParisB/lib_protocol/test/unit/dune b/src/proto_019_PtParisB/lib_protocol/test/unit/dune index e2feaa359488..52ad724c304b 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 3767520c9e00..d12171c5cf82 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 4a1ed1d2752b..5081f8a16321 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 000000000000..6fbd40779140 --- /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 -- GitLab From 9c98902a8064e3df76ca8701976daa257ab2cade Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 15:02:33 +0200 Subject: [PATCH 5/8] Proto/tests: backport validation tests Almost unchanged from Alpha. Had to remove one instance of the Host operation, that was mostly unused. --- .../test/integration/validate/dune | 2 - .../validate/manager_operation_helpers.ml | 75 +++-- .../validate/test_1m_restriction.ml | 9 +- .../integration/validate/test_covalidity.ml | 7 +- .../test_manager_operation_validation.ml | 18 +- .../test/integration/validate/test_mempool.ml | 27 +- .../test/integration/validate/test_sanity.ml | 18 +- .../validate/test_validation_batch.ml | 258 ++++++++---------- .../validate/valid_operations_generators.ml | 9 + .../integration/validate/validate_helpers.ml | 2 +- 10 files changed, 205 insertions(+), 220 deletions(-) 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 38681f6c24b1..fefb3bf80c8b 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 041cb34f2858..bb4fea69493f 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 4e8ab578767a..43d220772836 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 a3cc2c63fe9f..2632fc770f8f 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 376d519fe174..fa3b48188a36 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 1ed344ba12a9..052fad4efc85 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 75ac0a523c8a..17e103ef812f 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 950141484455..e4788463d16f 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 34b5a89f933c..488e0a214207 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 f0bfa891c963..3b46a81c6d8c 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 -- GitLab From d4afc2445b6a0ad7e04f0662c5a444326f44e48e Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 16:05:11 +0200 Subject: [PATCH 6/8] Proto/tests: backport consensus tests No changes from alpha --- .../test/integration/consensus/test_baking.ml | 14 ++--- .../consensus/test_consensus_key.ml | 2 +- .../consensus/test_deactivation.ml | 2 +- .../integration/consensus/test_delegation.ml | 5 +- .../consensus/test_double_attestation.ml | 60 +++++++++---------- .../consensus/test_double_baking.ml | 22 +++---- .../consensus/test_double_preattestation.ml | 10 ++-- .../consensus/test_frozen_deposits.ml | 48 +++++++-------- .../consensus/test_participation.ml | 5 +- .../test/integration/consensus/test_seed.ml | 18 +++--- 10 files changed, 90 insertions(+), 96 deletions(-) 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 4d49da6a4dd0..d562dea935c9 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 6278c4b1d45a..a3705ebaa03f 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 98f9a8a70293..f24faa3c7088 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 47899ef30f17..3df190603e06 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 c905e9bbfe61..67edd5683eae 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 48b16308e834..45fb1656202f 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 1b1c73da09a0..75b1c947f717 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 955ac2898a4b..5c576ea38f59 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 ee03cdcc6d8a..a5e31c42c1f6 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 8409efd6e7b2..8bfd3ad5fd29 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 -- GitLab From ffdc9216a42040566cbef6f175dd85a99af663e9 Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 16:09:47 +0200 Subject: [PATCH 7/8] Proto/tests: backport operation tests Unchanged from alpha, except test_host_operation.ml that has not been included. --- .../integration/operations/test_activation.ml | 4 +- .../operations/test_combined_operations.ml | 108 ++++++++---------- .../operations/test_origination.ml | 2 +- .../operations/test_paid_storage_increase.ml | 6 +- .../integration/operations/test_reveal.ml | 48 ++------ .../integration/operations/test_sc_rollup.ml | 27 +++-- .../integration/operations/test_transfer.ml | 2 +- .../integration/operations/test_voting.ml | 26 ++--- .../integration/operations/test_zk_rollup.ml | 3 +- 9 files changed, 94 insertions(+), 132 deletions(-) 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 ea9c6077d676..b4c2680b4236 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 4a888cdc3a67..aabab315dddb 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 309378cfe239..393701082a38 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 5bba4569f76f..ef243b832685 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 d703c7ee1478..ffd96c441d8e 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 ee5c02c3b0f8..257af9b27286 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 50b9189de72b..3dd1b929a1d0 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 24ad8eaae0ef..435aab0314a6 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 90a75b2d580a..2ed43aa0b209 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 -- GitLab From 38f640463462bd9289156b3a97ec21462b530776 Mon Sep 17 00:00:00 2001 From: Lucas Randazzo Date: Tue, 4 Jun 2024 15:00:22 +0200 Subject: [PATCH 8/8] Proto/tests: backport stragglers michelson, gas, pbt and regression are mostly untouched although I had to not backport michelson/test_ticket_balance.ml. --- .../test/integration/gas/test_gas_levels.ml | 2 +- .../michelson/test_contract_event.ml | 6 +++--- .../integration/michelson/test_sapling.ml | 19 +++++++++---------- .../michelson/test_ticket_accounting.ml | 2 +- .../michelson/test_ticket_operations_diff.ml | 2 +- .../lib_protocol/test/pbt/test_tez_repr.ml | 2 +- .../test/regression/test_logging.ml | 10 +++++++--- 7 files changed, 23 insertions(+), 20 deletions(-) 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 85e4c6afa5e1..53673770f75f 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 180cfc760afa..28729f9e1cf1 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 e8f7b0f83386..a2248df9bf47 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 31834e5628cf..21e947ee8419 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 eaaa40714419..95a4bab76c44 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/pbt/test_tez_repr.ml b/src/proto_019_PtParisB/lib_protocol/test/pbt/test_tez_repr.ml index 9648a6ff2aa1..8be5c0f97de5 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 770c856d8255..6426f0f6c181 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"; -- GitLab