{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.TxInfo (
  tests,
) where

import Cardano.Ledger.Address (Addr (..), BootstrapAddress (..))
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (
  ContextError,
  EraPlutusContext,
  LedgerTxInfo (..),
  toPlutusTxInfo,
 )
import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), transValidityInterval)
import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..))
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..), TxBody (..))
import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..), natVersion)
import qualified Cardano.Ledger.BaseTypes as BT (Inject (..), ProtVer (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Plutus.Language (SLanguage (..))
import Cardano.Ledger.State (UTxO (..))
import Cardano.Ledger.TxIn (TxIn (..), mkTxInPartial)
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..))
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import qualified Data.Map.Strict as Map
import Data.Proxy
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Shelley.Address.Bootstrap (aliceByronAddr)
import Test.Cardano.Ledger.Shelley.Examples.Cast (alicePHK)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))

byronAddr :: Addr
byronAddr :: Addr
byronAddr = BootstrapAddress -> Addr
AddrBootstrap (Address -> BootstrapAddress
BootstrapAddress Address
aliceByronAddr)

shelleyAddr :: Addr
shelleyAddr :: Addr
shelleyAddr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet PaymentCredential
alicePHK StakeReference
StakeRefNull

ei :: EpochInfo (Either a)
ei :: forall a. EpochInfo (Either a)
ei = EpochSize -> SlotLength -> EpochInfo (Either a)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (POSIXTime -> SlotLength
mkSlotLength POSIXTime
1)

ss :: SystemStart
ss :: SystemStart
ss = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

-- This input is only a "Byron input" in the sense
-- that we attach it to a Byron output in the UTxO created below.
byronInput :: TxIn
byronInput :: TxIn
byronInput = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
0

-- This input is only a "Shelley input" in the sense
-- that we attach it to a Shelley output in the UTxO created below.
shelleyInput :: TxIn
shelleyInput :: TxIn
shelleyInput = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
1

byronOutput :: TxOut AlonzoEra
byronOutput :: TxOut AlonzoEra
byronOutput = Addr
-> Value AlonzoEra -> StrictMaybe DataHash -> AlonzoTxOut AlonzoEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
byronAddr (Coin -> Value AlonzoEra
forall t s. Inject t s => t -> s
Val.inject (Coin -> Value AlonzoEra) -> Coin -> Value AlonzoEra
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1) StrictMaybe DataHash
forall a. StrictMaybe a
SNothing

shelleyOutput :: TxOut AlonzoEra
shelleyOutput :: TxOut AlonzoEra
shelleyOutput = Addr
-> Value AlonzoEra -> StrictMaybe DataHash -> AlonzoTxOut AlonzoEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
shelleyAddr (Coin -> Value AlonzoEra
forall t s. Inject t s => t -> s
Val.inject (Coin -> Value AlonzoEra) -> Coin -> Value AlonzoEra
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2) StrictMaybe DataHash
forall a. StrictMaybe a
SNothing

utxo :: UTxO AlonzoEra
utxo :: UTxO AlonzoEra
utxo = Map TxIn (TxOut AlonzoEra) -> UTxO AlonzoEra
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut AlonzoEra) -> UTxO AlonzoEra)
-> Map TxIn (TxOut AlonzoEra) -> UTxO AlonzoEra
forall a b. (a -> b) -> a -> b
$ [(TxIn, AlonzoTxOut AlonzoEra)] -> Map TxIn (AlonzoTxOut AlonzoEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn
byronInput, TxOut AlonzoEra
AlonzoTxOut AlonzoEra
byronOutput), (TxIn
shelleyInput, TxOut AlonzoEra
AlonzoTxOut AlonzoEra
shelleyOutput)]

txb :: TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb :: TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb TxIn
i TxOut AlonzoEra
o =
  Set TxIn
-> Set TxIn
-> StrictSeq (TxOut AlonzoEra)
-> StrictSeq (TxCert AlonzoEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AlonzoEra)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> TxBody AlonzoEra
AlonzoTxBody
    (TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
i) -- inputs
    Set TxIn
forall a. Monoid a => a
mempty -- collateral
    (AlonzoTxOut AlonzoEra -> StrictSeq (AlonzoTxOut AlonzoEra)
forall a. a -> StrictSeq a
StrictSeq.singleton TxOut AlonzoEra
AlonzoTxOut AlonzoEra
o) -- outputs
    StrictSeq (TxCert AlonzoEra)
StrictSeq (ShelleyTxCert AlonzoEra)
forall a. Monoid a => a
mempty -- certs
    (Map RewardAccount Coin -> Withdrawals
Withdrawals Map RewardAccount Coin
forall a. Monoid a => a
mempty) -- withdrawals
    (Integer -> Coin
Coin Integer
2) -- txfee
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing) -- validity interval
    StrictMaybe (Update AlonzoEra)
forall a. StrictMaybe a
SNothing -- updates
    Set (KeyHash 'Witness)
forall a. Monoid a => a
mempty -- required signers
    MultiAsset
forall a. Monoid a => a
mempty -- mint
    StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing -- script integrity hash
    StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing -- auxiliary data hash
    StrictMaybe Network
forall a. StrictMaybe a
SNothing -- network ID

txEx :: TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx :: TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx TxIn
i TxOut AlonzoEra
o = TxBody AlonzoEra
-> TxWits AlonzoEra
-> IsValid
-> StrictMaybe (TxAuxData AlonzoEra)
-> AlonzoTx AlonzoEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx (TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb TxIn
i TxOut AlonzoEra
o) TxWits AlonzoEra
AlonzoTxWits AlonzoEra
forall a. Monoid a => a
mempty (Bool -> IsValid
IsValid Bool
True) StrictMaybe (TxAuxData AlonzoEra)
StrictMaybe (AlonzoTxAuxData AlonzoEra)
forall a. StrictMaybe a
SNothing

silentlyIgnore :: Tx AlonzoEra -> Assertion
silentlyIgnore :: Tx AlonzoEra -> Assertion
silentlyIgnore Tx AlonzoEra
tx =
  let lti :: LedgerTxInfo AlonzoEra
lti =
        LedgerTxInfo
          { ltiProtVer :: ProtVer
ltiProtVer = Version -> Natural -> ProtVer
BT.ProtVer (forall era. Era era => Version
eraProtVerLow @AlonzoEra) Natural
0
          , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
forall a. EpochInfo (Either a)
ei
          , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
ss
          , ltiUTxO :: UTxO AlonzoEra
ltiUTxO = UTxO AlonzoEra
utxo
          , ltiTx :: Tx AlonzoEra
ltiTx = Tx AlonzoEra
tx
          }
   in case SLanguage 'PlutusV1
-> LedgerTxInfo AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1)
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
forall (proxy :: Language -> *).
proxy 'PlutusV1
-> LedgerTxInfo AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1)
toPlutusTxInfo SLanguage 'PlutusV1
SPlutusV1 LedgerTxInfo AlonzoEra
lti of
        Right PlutusTxInfo 'PlutusV1
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left ContextError AlonzoEra
e -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AlonzoContextError AlonzoEra -> String
forall a. Show a => a -> String
show ContextError AlonzoEra
AlonzoContextError AlonzoEra
e

-- | The test checks that the old implementation of 'transVITime' stays intentionally incorrect,
-- by returning close upper bound of the validaty interval.
transVITimeUpperBoundIsClosed ::
  forall era.
  ( EraPlutusContext era
  , BT.Inject (AlonzoContextError era) (ContextError era)
  ) =>
  Assertion
transVITimeUpperBoundIsClosed :: forall era.
(EraPlutusContext era,
 Inject (AlonzoContextError era) (ContextError era)) =>
Assertion
transVITimeUpperBoundIsClosed = 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))
  case Proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either (ContextError era) POSIXTimeRange
forall {k} (proxy :: k -> *) (era :: k) a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era) (Version -> Natural -> ProtVer
BT.ProtVer (forall era. Era era => Version
eraProtVerLow @era) Natural
0) EpochInfo (Either Text)
forall a. EpochInfo (Either a)
ei SystemStart
ss ValidityInterval
interval of
    Left (ContextError era
e :: ContextError era) ->
      String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContextError era -> String
forall a. Show a => a -> String
show ContextError era
e
    Right POSIXTimeRange
t ->
      POSIXTimeRange
t
        POSIXTimeRange -> POSIXTimeRange -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ( LowerBound POSIXTime -> UpperBound POSIXTime -> POSIXTimeRange
forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
                (Extended POSIXTime -> Bool -> LowerBound POSIXTime
forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound Extended POSIXTime
forall a. Extended a
PV1.NegInf Bool
True)
                (Extended POSIXTime -> Bool -> UpperBound POSIXTime
forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound (POSIXTime -> Extended POSIXTime
forall a. a -> Extended a
PV1.Finite (Integer -> POSIXTime
PV1.POSIXTime Integer
40000)) Bool
True)
            )

-- | The test checks that since protocol version 9 'transVITime' works correctly,
-- by returning open upper bound of the validaty interval.
transVITimeUpperBoundIsOpen ::
  forall era.
  ( EraPlutusContext era
  , BT.Inject (AlonzoContextError era) (ContextError era)
  ) =>
  Assertion
transVITimeUpperBoundIsOpen :: forall era.
(EraPlutusContext era,
 Inject (AlonzoContextError era) (ContextError era)) =>
Assertion
transVITimeUpperBoundIsOpen = 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))
  case Proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either (ContextError era) POSIXTimeRange
forall {k} (proxy :: k -> *) (era :: k) a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval
    (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era)
    (Version -> Natural -> ProtVer
BT.ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Natural
0)
    EpochInfo (Either Text)
forall a. EpochInfo (Either a)
ei
    SystemStart
ss
    ValidityInterval
interval of
    Left (ContextError era
e :: ContextError era) ->
      String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContextError era -> String
forall a. Show a => a -> String
show ContextError era
e
    Right POSIXTimeRange
t ->
      POSIXTimeRange
t
        POSIXTimeRange -> POSIXTimeRange -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ( LowerBound POSIXTime -> UpperBound POSIXTime -> POSIXTimeRange
forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
                (Extended POSIXTime -> Bool -> LowerBound POSIXTime
forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound Extended POSIXTime
forall a. Extended a
PV1.NegInf Bool
True)
                (Extended POSIXTime -> Bool -> UpperBound POSIXTime
forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound (POSIXTime -> Extended POSIXTime
forall a. a -> Extended a
PV1.Finite (Integer -> POSIXTime
PV1.POSIXTime Integer
40000)) Bool
False)
            )

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"txInfo translation"
    [ String -> [TestTree] -> TestTree
testGroup
        String
"Plutus V1"
        [ String -> Assertion -> TestTree
testCase String
"silently ignore byron txout" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Tx AlonzoEra -> Assertion
silentlyIgnore (TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx TxIn
shelleyInput TxOut AlonzoEra
byronOutput)
        , String -> Assertion -> TestTree
testCase String
"silently ignore byron txin" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Tx AlonzoEra -> Assertion
silentlyIgnore (TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx TxIn
byronInput TxOut AlonzoEra
shelleyOutput)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"transVITime"
        [ String -> Assertion -> TestTree
testCase
            String
"validity interval's upper bound is close when protocol < 9"
            (forall era.
(EraPlutusContext era,
 Inject (AlonzoContextError era) (ContextError era)) =>
Assertion
transVITimeUpperBoundIsClosed @AlonzoEra)
        , String -> Assertion -> TestTree
testCase
            String
"validity interval's upper bound is open when protocol >= 9"
            (forall era.
(EraPlutusContext era,
 Inject (AlonzoContextError era) (ContextError era)) =>
Assertion
transVITimeUpperBoundIsOpen @AlonzoEra)
        ]
    ]