{-# 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 (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.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
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 = 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
byronInput :: TxIn
byronInput = HasCallStack => 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
mkTxInPartial TxId
genesisId Integer
1

byronOutput :: TxOut AlonzoEra
byronOutput :: TxOut AlonzoEra
byronOutput = forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
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 AlonzoEra
shelleyOutput :: TxOut AlonzoEra
shelleyOutput = forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
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 AlonzoEra
utxo :: UTxO AlonzoEra
utxo = forall era. Map TxIn (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
byronInput, TxOut AlonzoEra
byronOutput), (TxIn
shelleyInput, TxOut AlonzoEra
shelleyOutput)]

txb :: TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb :: TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb TxIn
i TxOut AlonzoEra
o =
  forall era.
(EraTxOut era, EraTxCert era) =>
Set TxIn
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> AlonzoTxBody era
AlonzoTxBody
    (forall a. a -> Set a
Set.singleton TxIn
i) -- inputs
    forall a. Monoid a => a
mempty -- collateral
    (forall a. a -> StrictSeq a
StrictSeq.singleton TxOut AlonzoEra
o) -- outputs
    forall a. Monoid a => a
mempty -- certs
    (Map RewardAccount Coin -> Withdrawals
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 -> TxOut AlonzoEra -> Tx AlonzoEra
txEx :: TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx TxIn
i TxOut AlonzoEra
o = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx (TxIn -> TxOut AlonzoEra -> TxBody AlonzoEra
txb TxIn
i TxOut AlonzoEra
o) forall a. Monoid a => a
mempty (Bool -> IsValid
IsValid Bool
True) 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 = 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 forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo SLanguage 'PlutusV1
SPlutusV1 LedgerTxInfo AlonzoEra
lti of
        Right PlutusTxInfo 'PlutusV1
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left ContextError AlonzoEra
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
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 {k} (proxy :: k -> *) (era :: k) 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 {k} (proxy :: k -> *) (era :: k) 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 -> Assertion
silentlyIgnore (TxIn -> TxOut AlonzoEra -> Tx AlonzoEra
txEx TxIn
shelleyInput TxOut AlonzoEra
byronOutput)
        , String -> Assertion -> TestTree
testCase String
"silently ignore byron txin" 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)
        ]
    ]