{-# 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
(Int -> Expectation -> ShowS)
-> (Expectation -> String)
-> ([Expectation] -> ShowS)
-> Show Expectation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expectation -> ShowS
showsPrec :: Int -> Expectation -> ShowS
$cshow :: Expectation -> String
show :: Expectation -> String
$cshowList :: [Expectation] -> ShowS
showList :: [Expectation] -> ShowS
Show, Expectation -> Expectation -> Bool
(Expectation -> Expectation -> Bool)
-> (Expectation -> Expectation -> Bool) -> Eq Expectation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expectation -> Expectation -> Bool
== :: Expectation -> Expectation -> Bool
$c/= :: Expectation -> Expectation -> Bool
/= :: 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 =
        ShelleyBase
  (Either
     (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra))
-> Either
     (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra))
 -> Either
      (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra))
-> Either
     (NonEmpty (ShelleyPoolPredFailure ShelleyEra)) (PState ShelleyEra)
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)
            ( (Environment (ShelleyPOOL ShelleyEra),
 State (ShelleyPOOL ShelleyEra), Signal (ShelleyPOOL ShelleyEra))
-> TRC (ShelleyPOOL ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( EpochNo -> PParams ShelleyEra -> PoolEnv ShelleyEra
forall era. EpochNo -> PParams era -> PoolEnv era
PoolEnv (Word64 -> EpochNo
EpochNo Word64
0) (PParams ShelleyEra -> PoolEnv ShelleyEra)
-> PParams ShelleyEra -> PoolEnv ShelleyEra
forall a b. (a -> b) -> a -> b
$ PParams ShelleyEra
forall era. EraPParams era => PParams era
emptyPParams PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams ShelleyEra) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> ProtVer -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv
                , PState ShelleyEra
State (ShelleyPOOL ShelleyEra)
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
String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Left NonEmpty (ShelleyPoolPredFailure ShelleyEra)
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
"" Bool
True
    (Right PState ShelleyEra
_, Expectation
ExpectFailure) -> HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
"We expected failure." Bool
False
    (Left NonEmpty (ShelleyPoolPredFailure ShelleyEra)
_, Expectation
ExpectSuccess) -> HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
"We expected success." Bool
False

matchingNetworkIDPoolParams :: PoolParams
matchingNetworkIDPoolParams :: PoolParams
matchingNetworkIDPoolParams =
  PoolParams
Cast.alicePoolParams {ppRewardAccount = RewardAccount Testnet Cast.aliceSHK}

-- test globals use Testnet

mismatchingNetworkIDPoolParams :: PoolParams
mismatchingNetworkIDPoolParams :: PoolParams
mismatchingNetworkIDPoolParams =
  PoolParams
Cast.alicePoolParams {ppRewardAccount = RewardAccount Mainnet 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" (Assertion -> TestTree) -> Assertion -> TestTree
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" (Assertion -> TestTree) -> Assertion -> TestTree
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" (Assertion -> TestTree) -> Assertion -> TestTree
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" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        ProtVer -> PoolParams -> Expectation -> Assertion
testPoolNetworkID
          ProtVer
alonzoPV
          PoolParams
matchingNetworkIDPoolParams
          Expectation
ExpectSuccess
    ]