{-# 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 (Alonzo)
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 (AlonzoTxBody (..), AlonzoTxOut (..))
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.Crypto (StandardCrypto)
import Cardano.Ledger.Plutus.Language (SLanguage (..))
import Cardano.Ledger.TxIn (TxIn (..), mkTxInPartial)
import Cardano.Ledger.UTxO (UTxO (..))
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 StandardCrypto
byronAddr :: Addr StandardCrypto
byronAddr = forall c. BootstrapAddress c -> Addr c
AddrBootstrap (forall c. Address -> BootstrapAddress c
BootstrapAddress Address
aliceByronAddr)

shelleyAddr :: Addr StandardCrypto
shelleyAddr :: Addr StandardCrypto
shelleyAddr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet forall c. Crypto c => Credential 'Payment c
alicePHK forall c. StakeReference c
StakeRefNull

ei :: EpochInfo (Either a)
ei :: forall a. EpochInfo (Either a)
ei = 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 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 StandardCrypto
byronInput :: TxIn StandardCrypto
byronInput = forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
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 StandardCrypto
shelleyInput :: TxIn StandardCrypto
shelleyInput = forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
genesisId Integer
1

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

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

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

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

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

silentlyIgnore :: Tx Alonzo -> Assertion
silentlyIgnore :: Tx (AlonzoEra StandardCrypto) -> Assertion
silentlyIgnore Tx (AlonzoEra StandardCrypto)
tx =
  let lti :: LedgerTxInfo (AlonzoEra StandardCrypto)
lti =
        LedgerTxInfo
          { ltiProtVer :: ProtVer
ltiProtVer = Version -> Natural -> ProtVer
BT.ProtVer (forall era. Era era => Version
eraProtVerLow @Alonzo) Natural
0
          , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = forall a. EpochInfo (Either a)
ei
          , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
ss
          , ltiUTxO :: UTxO (AlonzoEra StandardCrypto)
ltiUTxO = UTxO (AlonzoEra StandardCrypto)
utxo
          , ltiTx :: Tx (AlonzoEra StandardCrypto)
ltiTx = Tx (AlonzoEra StandardCrypto)
tx
          }
   in case forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo SLanguage 'PlutusV1
SPlutusV1 LedgerTxInfo (AlonzoEra StandardCrypto)
lti of
        Right PlutusTxInfo 'PlutusV1
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left ContextError (AlonzoEra StandardCrypto)
e -> forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ContextError (AlonzoEra StandardCrypto)
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 forall a. StrictMaybe a
SNothing (forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
40))
  case forall (proxy :: * -> *) era a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval (forall {k} (t :: k). Proxy t
Proxy @era) (Version -> Natural -> ProtVer
BT.ProtVer (forall era. Era era => Version
eraProtVerLow @era) Natural
0) forall a. EpochInfo (Either a)
ei SystemStart
ss ValidityInterval
interval of
    Left (ContextError era
e :: ContextError era) ->
      forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ContextError era
e
    Right POSIXTimeRange
t ->
      POSIXTimeRange
t
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ( forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
                (forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound forall a. Extended a
PV1.NegInf Bool
True)
                (forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound (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 forall a. StrictMaybe a
SNothing (forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
40))
  case forall (proxy :: * -> *) era a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval
    (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)
    forall a. EpochInfo (Either a)
ei
    SystemStart
ss
    ValidityInterval
interval of
    Left (ContextError era
e :: ContextError era) ->
      forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"no translation error was expected, but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ContextError era
e
    Right POSIXTimeRange
t ->
      POSIXTimeRange
t
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ( forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
                (forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound forall a. Extended a
PV1.NegInf Bool
True)
                (forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound (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" forall a b. (a -> b) -> a -> b
$
            Tx (AlonzoEra StandardCrypto) -> Assertion
silentlyIgnore (TxIn StandardCrypto
-> TxOut (AlonzoEra StandardCrypto)
-> Tx (AlonzoEra StandardCrypto)
txEx TxIn StandardCrypto
shelleyInput TxOut (AlonzoEra StandardCrypto)
byronOutput)
        , String -> Assertion -> TestTree
testCase String
"silently ignore byron txin" forall a b. (a -> b) -> a -> b
$
            Tx (AlonzoEra StandardCrypto) -> Assertion
silentlyIgnore (TxIn StandardCrypto
-> TxOut (AlonzoEra StandardCrypto)
-> Tx (AlonzoEra StandardCrypto)
txEx TxIn StandardCrypto
byronInput TxOut (AlonzoEra StandardCrypto)
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 @Alonzo)
        , 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 @Alonzo)
        ]
    ]