{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.Examples.NetworkID (
  testPoolNetworkId,
)
where

import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API (
  Network (..),
  PoolEnv (..),
  PoolParams (..),
  RewardAccount (..),
  ShelleyPOOL,
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Slot (EpochNo (..))
import Control.State.Transition.Extended hiding (Assertion)
import Data.Default (def)
import Lens.Micro
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, testCase)

shelleyPV :: ProtVer
shelleyPV :: ProtVer
shelleyPV = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) Natural
0

alonzoPV :: ProtVer
alonzoPV :: ProtVer
alonzoPV = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @5) Natural
0

data Expectation = ExpectSuccess | ExpectFailure
  deriving (Int -> Expectation -> ShowS
[Expectation] -> ShowS
Expectation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expectation] -> ShowS
$cshowList :: [Expectation] -> ShowS
show :: Expectation -> String
$cshow :: Expectation -> String
showsPrec :: Int -> Expectation -> ShowS
$cshowsPrec :: Int -> Expectation -> ShowS
Show, Expectation -> Expectation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expectation -> Expectation -> Bool
$c/= :: Expectation -> Expectation -> Bool
== :: Expectation -> Expectation -> Bool
$c== :: Expectation -> Expectation -> Bool
Eq)

testPoolNetworkID ::
  ProtVer ->
  PoolParams ->
  Expectation ->
  Assertion
testPoolNetworkID :: ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID ProtVer
pv PoolParams
poolParams Expectation
e = do
  let st :: Either
  (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra)
st =
        forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyPOOL ShelleyEra)
            ( forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( forall era. EpochNo -> PParams era -> PoolEnv era
PoolEnv (Word64 -> EpochNo
EpochNo Word64
0) forall a b. (a -> b) -> a -> b
$ forall era. EraPParams era => PParams era
emptyPParams forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv
                , forall a. Default a => a
def
                , PoolParams -> PoolCert
RegPool PoolParams
poolParams
                )
            )
  case (Either
  (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra)
st, Expectation
e) of
    (Right PState ShelleyEra
_, Expectation
ExpectSuccess) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Left NonEmpty (ShelleyPoolPredFailure ShelleyEra)
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Right PState ShelleyEra
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"We expected failure." Bool
False
    (Left NonEmpty (ShelleyPoolPredFailure ShelleyEra)
_, Expectation
ExpectSuccess) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"We expected success." Bool
False

matchingNetworkIDPoolParams :: PoolParams
matchingNetworkIDPoolParams :: PoolParams
matchingNetworkIDPoolParams =
  PoolParams
Cast.alicePoolParams {ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
Cast.aliceSHK}

-- test globals use Testnet

mismatchingNetworkIDPoolParams :: PoolParams
mismatchingNetworkIDPoolParams :: PoolParams
mismatchingNetworkIDPoolParams =
  PoolParams
Cast.alicePoolParams {ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Mainnet Credential 'Staking
Cast.aliceSHK}

-- test globals use Testnet

testPoolNetworkId :: TestTree
testPoolNetworkId :: TestTree
testPoolNetworkId =
  String -> [TestTree] -> TestTree
testGroup
    String
"Network IDs"
    [ String -> Assertion -> TestTree
testCase String
"Incorrect Network ID is allowed pre-Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
shelleyPV
          PoolParams
mismatchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    , String -> Assertion -> TestTree
testCase String
"Incorrect Network ID is NOT allowed in Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
alonzoPV
          PoolParams
mismatchingNetworkIDPoolParams
          Expectation
ExpectFailure
    , String -> Assertion -> TestTree
testCase String
"Correct Network ID is allowed pre-Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
shelleyPV
          PoolParams
matchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    , String -> Assertion -> TestTree
testCase String
"Correct Network ID is allowed in Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
alonzoPV
          PoolParams
matchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    ]