{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conformance.Imp.Conway.Ratify (spec) where

import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance (
  Committee (..),
  GovAction (..),
  GovPurposeId (..),
  RatifySignal (..),
  Voter (..),
  committeeGovStateL,
  getRatifyState,
 )
import Cardano.Ledger.Conway.PParams (
  dvtMotionNoConfidenceL,
  pvtMotionNoConfidenceL,
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.LedgerState (
  epochStateGovStateL,
  nesELL,
  nesEsL,
 )
import Control.State.Transition (TRC (..))
import Data.Bifunctor (Bifunctor (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Text as T
import Lens.Micro ((&), (.~))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Conformance (
  ConformanceResult (..),
  ExecSpecRule (..),
  runConformance,
 )
import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway ()
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common

spec :: Spec
spec :: Spec
spec = forall t. ImpSpec t => SpecWith (ImpInit t) -> Spec
withImpInit @(LedgerSpec ConwayEra) (SpecWith (ImpInit (LedgerSpec ConwayEra)) -> Spec)
-> SpecWith (ImpInit (LedgerSpec ConwayEra)) -> Spec
forall a b. (a -> b) -> a -> b
$ String
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RATIFY" (SpecWith (ImpInit (LedgerSpec ConwayEra))
 -> SpecWith (ImpInit (LedgerSpec ConwayEra)))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
forall a b. (a -> b) -> a -> b
$ Version
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
forall era.
(ShelleyEraImp era, ShelleyEraImp era) =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer (forall era. Era era => Version
eraProtVerHigh @ConwayEra) (SpecWith (ImpInit (LedgerSpec ConwayEra))
 -> SpecWith (ImpInit (LedgerSpec ConwayEra)))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec ConwayEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NoConfidence accepted conforms" (ImpM (LedgerSpec ConwayEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ())))
-> ImpM (LedgerSpec ConwayEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams ConwayEra -> PParams ConwayEra)
-> ImpM (LedgerSpec ConwayEra) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams ConwayEra -> PParams ConwayEra)
 -> ImpM (LedgerSpec ConwayEra) ())
-> (PParams ConwayEra -> PParams ConwayEra)
-> ImpM (LedgerSpec ConwayEra) ()
forall a b. (a -> b) -> a -> b
$ \PParams ConwayEra
pp ->
      PParams ConwayEra
pp
        PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams ConwayEra) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams ConwayEra
-> Identity (PParams ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> UnitInterval -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
9 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10
        PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams ConwayEra) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams ConwayEra
-> Identity (PParams ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> UnitInterval -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
    (dRep, _, _) <- ImpTestM
  ConwayEra
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
    lastCommittee <- getLastEnactedCommittee
    noConfidence <- submitGovAction $ NoConfidence lastCommittee
    submitYesVote_ (DRepVoter dRep) noConfidence
    ratEnv <- getRatifyEnv
    govSt <- getsNES $ nesEsL . epochStateGovStateL
    let ratSt = ConwayGovState ConwayEra -> RatifyState ConwayEra
forall era.
(ConwayEraAccounts era, EraStake era) =>
ConwayGovState era -> RatifyState era
getRatifyState ConwayGovState ConwayEra
govSt
    noConfidenceGAS <- getGovActionState noConfidence
    passNEpochs 2
    getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId noConfidence)
    let trc = (Environment (ConwayRATIFY ConwayEra),
 State (ConwayRATIFY ConwayEra), Signal (ConwayRATIFY ConwayEra))
-> TRC (ConwayRATIFY ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (RatifyEnv ConwayEra
Environment (ConwayRATIFY ConwayEra)
ratEnv, RatifyState ConwayEra
State (ConwayRATIFY ConwayEra)
ratSt, StrictSeq (GovActionState ConwayEra) -> RatifySignal ConwayEra
forall era. StrictSeq (GovActionState era) -> RatifySignal era
RatifySignal (GovActionState ConwayEra
noConfidenceGAS GovActionState ConwayEra
-> StrictSeq (GovActionState ConwayEra)
-> StrictSeq (GovActionState ConwayEra)
forall a. a -> StrictSeq a -> StrictSeq a
SSeq.:<| StrictSeq (GovActionState ConwayEra)
forall a. StrictSeq a
SSeq.Empty))
    res <- runConformance @"RATIFY" @ConwayEra () trc
    case res of
      ConformanceResult Right {} Right {} Right {} -> () -> ImpM (LedgerSpec ConwayEra) ()
forall a. a -> ImpM (LedgerSpec ConwayEra) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      ConformanceResult "RATIFY" ConwayEra
failure -> String -> ImpM (LedgerSpec ConwayEra) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure (String -> ImpM (LedgerSpec ConwayEra) ())
-> String -> ImpM (LedgerSpec ConwayEra) ()
forall a b. (a -> b) -> a -> b
$ String
"Expected success, got:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ConformanceResult "RATIFY" ConwayEra -> String
forall a. ToExpr a => a -> String
showExpr ConformanceResult "RATIFY" ConwayEra
failure
  String
-> ImpM (LedgerSpec ConwayEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Duplicate CC hot keys count as separate votes" (ImpM (LedgerSpec ConwayEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ())))
-> ImpM (LedgerSpec ConwayEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec ConwayEra) ()))
forall a b. (a -> b) -> a -> b
$ do
    String -> ImpM (LedgerSpec ConwayEra) ()
forall t. HasCallStack => String -> ImpM t ()
logString String
"Setting up a DRep"
    let maxTermLength :: EpochInterval
maxTermLength = Word32 -> EpochInterval
EpochInterval Word32
10
    (PParams ConwayEra -> PParams ConwayEra)
-> ImpM (LedgerSpec ConwayEra) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams ConwayEra -> PParams ConwayEra)
 -> ImpM (LedgerSpec ConwayEra) ())
-> (PParams ConwayEra -> PParams ConwayEra)
-> ImpM (LedgerSpec ConwayEra) ()
forall a b. (a -> b) -> a -> b
$ \PParams ConwayEra
pp ->
      PParams ConwayEra
pp
        PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams ConwayEra) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> EpochInterval -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval
maxTermLength
        PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (CoinPerByte -> Identity CoinPerByte)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams ConwayEra) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> CoinPerByte -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
1)
        PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams ConwayEra) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams ConwayEra -> Identity (PParams ConwayEra))
-> Natural -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
2
    (credDRep, _, _) <- Integer
-> ImpTestM
     ConwayEra
     (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
300
    (credSPO, _, _) <- setupPoolWithStake $ Coin 1_000_000
    -- Ensure that there is no committee yet
    SJust (Committee {committeeMembers = oldCommittee}) <-
      getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL

    logString "Electing the committee"
    ccCold0 <- KeyHashObj <$> freshKeyHash
    ccCold1 <- KeyHashObj <$> freshKeyHash
    ccCold2 <- KeyHashObj <$> freshKeyHash
    hotKey <- KeyHashObj <$> freshKeyHash
    curEpoch <- getsNES nesELL
    let
      ccExpiry = EpochNo
curEpoch EpochNo -> EpochInterval -> EpochNo
`addEpochInterval` EpochInterval
maxTermLength
      committee =
        [(Credential ColdCommitteeRole, EpochNo)]
-> Map (Credential ColdCommitteeRole) EpochNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Credential ColdCommitteeRole
ccCold0, EpochNo
ccExpiry)
          , (Credential ColdCommitteeRole
ccCold1, EpochNo
ccExpiry)
          , (Credential ColdCommitteeRole
ccCold2, EpochNo
ccExpiry)
          ]
    committeeId <-
      submitGovAction $
        UpdateCommittee
          SNothing
          (Map.keysSet oldCommittee) -- Get rid of the initial committee
          committee
          (6 %! 10)
    submitYesVote_ (DRepVoter credDRep) committeeId
    submitYesVote_ (StakePoolVoter credSPO) committeeId
    impAnn "Waiting for the committee to get elected" $ do
      logAcceptedRatio committeeId
      passNEpochs 2
      getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId committeeId)

    logString "Registering hotkeys"
    _ <- registerCommitteeHotKeys (pure hotKey) (ccCold0 NE.:| [ccCold1])

    logString "Proposing a new constitution"
    newConstitution <- arbitrary
    constitutionId <- submitGovAction $ NewConstitution SNothing newConstitution
    submitYesVote_ (CommitteeVoter hotKey) constitutionId
    submitYesVote_ (DRepVoter credDRep) constitutionId
    constitutionGAS <- getGovActionState constitutionId

    logString "Testing conformance"
    ratEnv <- getRatifyEnv
    govSt <- getsNES $ nesEsL . epochStateGovStateL
    let
      ratSt = ConwayGovState ConwayEra -> RatifyState ConwayEra
forall era.
(ConwayEraAccounts era, EraStake era) =>
ConwayGovState era -> RatifyState era
getRatifyState ConwayGovState ConwayEra
govSt
      ratSig = StrictSeq (GovActionState ConwayEra) -> RatifySignal ConwayEra
forall era. StrictSeq (GovActionState era) -> RatifySignal era
RatifySignal (GovActionState ConwayEra
constitutionGAS GovActionState ConwayEra
-> StrictSeq (GovActionState ConwayEra)
-> StrictSeq (GovActionState ConwayEra)
forall a. a -> StrictSeq a -> StrictSeq a
SSeq.:<| StrictSeq (GovActionState ConwayEra)
forall a. Monoid a => a
mempty)
      trc = (Environment (ConwayRATIFY ConwayEra),
 State (ConwayRATIFY ConwayEra), Signal (ConwayRATIFY ConwayEra))
-> TRC (ConwayRATIFY ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (RatifyEnv ConwayEra
Environment (ConwayRATIFY ConwayEra)
ratEnv, RatifyState ConwayEra
State (ConwayRATIFY ConwayEra)
ratSt, RatifySignal ConwayEra
Signal (ConwayRATIFY ConwayEra)
ratSig)
    (ConformanceResult implRes agdaRes implRes') <-
      runConformance @"RATIFY" @ConwayEra () trc
    logString "===environment==="
    logToExpr ratEnv
    logString "===state==="
    logToExpr ratSt
    logString "===signal==="
    logToExpr ratSig
    logString "Impl res:"
    logToExpr implRes
    logString "Agda res:"
    logToExpr agdaRes
    logString "Extra information:"
    globals <- use impGlobalsL
    logDoc $
      extraInfo @"RATIFY" @ConwayEra globals () trc (first (T.pack . show) implRes')
    impAnn "Conformance failed" $
      first (T.pack . show) implRes `shouldBeExpr` agdaRes