{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.TxInfoSpec (spec) where

import Cardano.Ledger.Alonzo.Plutus.Context (toPlutusTxCert)
import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.TxCert
import qualified Cardano.Ledger.Conway.TxInfo as Conway
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Plutus.Language (Language (..))
import Data.Either (isRight)
import Data.Proxy (Proxy (..))
import qualified PlutusLedgerApi.V1 as PV1
import qualified PlutusLedgerApi.V2 as PV2
import qualified PlutusLedgerApi.V3 as PV3
import Test.Cardano.Ledger.Alonzo.ImpTest (genBadValidityInterval, genGoodValidityInterval)
import Test.Cardano.Ledger.Alonzo.TxInfoSpec (
  testEpochInfo,
  testSystemStart,
  validBetweenEpochInfo,
 )
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Genesis ()
import Test.Cardano.Ledger.Core.Arbitrary (genOrderedPair)

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let trans :: ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans ProtVer
pv ConwayTxCert ConwayEra
cert = (ConwayContextError ConwayEra -> TxCert)
-> (TxCert -> TxCert)
-> Either (ConwayContextError ConwayEra) TxCert
-> TxCert
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> TxCert
forall a. HasCallStack => String -> a
error (String -> TxCert)
-> (ConwayContextError ConwayEra -> String)
-> ConwayContextError ConwayEra
-> TxCert
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayContextError ConwayEra -> String
forall a. Show a => a -> String
show) TxCert -> TxCert
forall a. a -> a
id (forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> TxCert era
-> Either (ContextError era) (PlutusTxCert l)
toPlutusTxCert @'PlutusV3 @ConwayEra Proxy 'PlutusV3
forall {k} (t :: k). Proxy t
Proxy ProtVer
pv TxCert ConwayEra
ConwayTxCert ConwayEra
cert)
        transV9 :: ConwayTxCert ConwayEra -> TxCert
transV9 = ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans (Version -> Word32 -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Word32
0)
        transV10 :: ConwayTxCert ConwayEra -> TxCert
transV10 = ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans (Version -> Word32 -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Word32
0)

    String -> (Credential Staking -> Coin -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Deposit in registration certs" ((Credential Staking -> Coin -> IO ()) -> Spec)
-> (Credential Staking -> Coin -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(Credential Staking
cred :: Credential Staking) (Coin
coin :: Coin) -> do
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert Credential Staking
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ Credential Staking -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert Credential Staking
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert Credential Staking
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ Credential Staking -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert Credential Staking
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

    String -> (Credential Staking -> Coin -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Deposit in unregistration certs" ((Credential Staking -> Coin -> IO ()) -> Spec)
-> (Credential Staking -> Coin -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(Credential Staking
cred :: Credential Staking) (Coin
coin :: Coin) -> do
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert Credential Staking
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ Credential Staking -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert Credential Staking
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert Credential Staking
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ Credential Staking -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert Credential Staking
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Translation" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"transValidityInterval" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        -- The test checks that since protocol version 9 'transVITime' works correctly,
        -- by returning open upper bound of the validaty interval.
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"validity interval's upper bound is open when protocol >= 9" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let interval :: ValidityInterval
interval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
40))
          Proxy ConwayEra
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either (ContextError ConwayEra) POSIXTimeRange
forall (proxy :: * -> *) era.
Inject (AlonzoContextError era) (ContextError era) =>
proxy era
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either (ContextError era) POSIXTimeRange
Conway.transValidityInterval (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ConwayEra) EpochInfo (Either Text)
forall a. EpochInfo (Either a)
testEpochInfo SystemStart
testSystemStart ValidityInterval
interval
            Either (ConwayContextError ConwayEra) POSIXTimeRange
-> POSIXTimeRange -> IO ()
forall a b.
(HasCallStack, Show a, Show b, Eq b) =>
Either a b -> b -> IO ()
`shouldBeRight` LowerBound POSIXTime -> UpperBound POSIXTime -> POSIXTimeRange
forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
              (Extended POSIXTime -> Closure -> LowerBound POSIXTime
forall a. Extended a -> Closure -> LowerBound a
PV1.LowerBound Extended POSIXTime
forall a. Extended a
PV1.NegInf Closure
True)
              (Extended POSIXTime -> Closure -> UpperBound POSIXTime
forall a. Extended a -> Closure -> UpperBound a
PV1.UpperBound (POSIXTime -> Extended POSIXTime
forall a. a -> Extended a
PV1.Finite (Integer -> POSIXTime
PV1.POSIXTime Integer
40000)) Closure
False)
        String -> Gen (IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"translates successfully if bounds are valid" (Gen (IO ()) -> Spec) -> Gen (IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ do
          (hi, lo) <- Gen (SlotNo, SlotNo)
forall a. (Arbitrary a, Ord a) => Gen (a, a)
genOrderedPair
          validityInterval <- genGoodValidityInterval lo hi
          pure $
            Conway.transValidityInterval
              (Proxy @ConwayEra)
              (validBetweenEpochInfo lo hi)
              testSystemStart
              validityInterval
              `shouldSatisfy` isRight
        String -> Gen (IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fails to translate if the bounds are invalid" (Gen (IO ()) -> Spec) -> Gen (IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ do
          (hi, lo) <- Gen (SlotNo, SlotNo)
forall a. (Arbitrary a, Ord a) => Gen (a, a)
genOrderedPair
          validityInterval <- genBadValidityInterval lo hi
          pure $
            Conway.transValidityInterval
              (Proxy @ConwayEra)
              (validBetweenEpochInfo lo hi)
              testSystemStart
              validityInterval
              `shouldBeLeft` inject (TimeTranslationPastHorizon @ConwayEra "out of valid range")
  where
    expectDeposit :: Coin -> PV3.TxCert -> IO ()
    expectDeposit :: Coin -> TxCert -> IO ()
expectDeposit (Coin Integer
c) =
      \case
        PV3.TxCertRegStaking Credential
_ (Just Lovelace
d) -> Integer -> Lovelace
PV2.Lovelace Integer
c Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Lovelace
d
        PV3.TxCertUnRegStaking Credential
_ (Just Lovelace
d) -> Integer -> Lovelace
PV2.Lovelace Integer
c Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Lovelace
d
        TxCert
txcert ->
          HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Deposit: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (Integer -> Coin
Coin Integer
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" expected in: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxCert -> String
forall a. Show a => a -> String
show TxCert
txcert String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but not found"
    expectNoDeposit :: PV3.TxCert -> IO ()
    expectNoDeposit :: TxCert -> IO ()
expectNoDeposit =
      \case
        PV3.TxCertRegStaking Credential
_ Maybe Lovelace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        PV3.TxCertUnRegStaking Credential
_ Maybe Lovelace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TxCert
txcert ->
          HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Deposit not expected, but found in: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxCert -> String
forall a. Show a => a -> String
show TxCert
txcert