{-# 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 Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto)
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)

type ShelleyTest = ShelleyEra C_Crypto

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 C_Crypto ->
  Expectation ->
  Assertion
testPoolNetworkID :: ProtVer -> PoolParams C_Crypto -> Expectation -> Assertion
testPoolNetworkID ProtVer
pv PoolParams C_Crypto
poolParams Expectation
e = do
  let st :: Either
  (NonEmpty (ShelleyPoolPredFailure (ShelleyEra C_Crypto)))
  (PState (ShelleyEra C_Crypto))
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 ShelleyTest)
            ( 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
                , forall c. PoolParams c -> PoolCert c
RegPool PoolParams C_Crypto
poolParams
                )
            )
  case (Either
  (NonEmpty (ShelleyPoolPredFailure (ShelleyEra C_Crypto)))
  (PState (ShelleyEra C_Crypto))
st, Expectation
e) of
    (Right PState (ShelleyEra C_Crypto)
_, Expectation
ExpectSuccess) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Left NonEmpty (ShelleyPoolPredFailure (ShelleyEra C_Crypto))
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Right PState (ShelleyEra C_Crypto)
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"We expected failure." Bool
False
    (Left NonEmpty (ShelleyPoolPredFailure (ShelleyEra C_Crypto))
_, Expectation
ExpectSuccess) -> HasCallStack => String -> Bool -> Assertion
assertBool String
"We expected success." Bool
False

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

-- test globals use Testnet

mismatchingNetworkIDPoolParams :: PoolParams C_Crypto
mismatchingNetworkIDPoolParams :: PoolParams C_Crypto
mismatchingNetworkIDPoolParams =
  forall c. Crypto c => PoolParams c
Cast.alicePoolParams {ppRewardAccount :: RewardAccount C_Crypto
ppRewardAccount = forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Mainnet forall c. Crypto c => Credential 'Staking c
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 C_Crypto -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
shelleyPV
          PoolParams C_Crypto
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 C_Crypto -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
alonzoPV
          PoolParams C_Crypto
mismatchingNetworkIDPoolParams
          Expectation
ExpectFailure
    , String -> Assertion -> TestTree
testCase String
"Correct Network ID is allowed pre-Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams C_Crypto -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
shelleyPV
          PoolParams C_Crypto
matchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    , String -> Assertion -> TestTree
testCase String
"Correct Network ID is allowed in Alonzo" forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams C_Crypto -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
alonzoPV
          PoolParams C_Crypto
matchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    ]