{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoPredFailure (..))
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxAuxData (mkAlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..), toDeltaCoin)
import qualified Cardano.Ledger.Metadata as M
import Cardano.Ledger.Plutus (Data (..), ExUnits (..), hashPlutusScript, withSLanguage)
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
import Control.Monad (forM)
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import Lens.Micro (to, (&), (.~), (<>~), (^.))
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum)

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
  ) =>
  SpecWith (ImpTestState era)
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era) =>
SpecWith (ImpTestState era)
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Wrong network ID" forall a b. (a -> b) -> a -> b
$ do
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      (forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Network)
networkIdTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Network
Mainnet)
      [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Network -> Network -> AlonzoUtxoPredFailure era
WrongNetworkInTxBody Network
Testnet Network
Mainnet]

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall a. Show a => a -> String
show Language
lang) forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Too many execution units for tx" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          ExUnits
maxExUnits <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
          let
            txExUnits :: ExUnits
txExUnits = ExUnits
maxExUnits forall a. Semigroup a => a -> a -> a
<> Natural -> Natural -> ExUnits
ExUnits Natural
1 Natural
1
            prp :: PlutusPurpose AsIx era
prp = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era
mkSpendingPurpose (forall ix it. ix -> AsIx ix it
AsIx Word32
0)
            dat :: Data era
dat = forall era. Era era => Data -> Data era
Data forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
32
            tx :: Tx era
tx =
              forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
txIn]
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (forall k a. k -> a -> Map k a
Map.singleton PlutusPurpose AsIx era
prp (Data era
dat, ExUnits
txExUnits))
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ExUnits -> ExUnits -> AlonzoUtxoPredFailure era
ExUnitsTooBigUTxO ExUnits
maxExUnits ExUnits
txExUnits]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Insufficient collateral" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
scriptInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript forall a b. (a -> b) -> a -> b
$ forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          Addr (EraCrypto era)
collateralAddr <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
          TxIn (EraCrypto era)
collateralInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
collateralAddr forall a. Monoid a => a
mempty -- 0 will be changed to MinUTxO
          Coin
collateral <- (forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ShelleyEraImp era =>
TxIn (EraCrypto era) -> ImpTestM era (TxOut era)
impLookupUTxO TxIn (EraCrypto era)
collateralInput
          -- We need to artificially blow up the fee to increase the required collateral.
          -- Unfortunately we do not have expensive enough scripts yet, so one other way
          -- to achieve the same thing is by increasing the size of the transactions by
          -- including random garbage. Auxiliary data fits the bill quite nicely
          Map Word64 Metadatum
metadata <-
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word64
1 .. (Word64
12 forall a. Num a => a -> a -> a
* Word64
1024 forall a. Integral a => a -> a -> a
`div` Word64
64)] (\Word64
ix -> (,) Word64
ix forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Metadatum
M.B forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteString
uniformByteStringM Int
64)
          let auxData :: AlonzoTxAuxData era
auxData = forall (f :: * -> *) era.
(Foldable f, AlonzoEraScript era) =>
Map Word64 Metadatum -> f (AlonzoScript era) -> AlonzoTxAuxData era
mkAlonzoTxAuxData @[] @era Map Word64 Metadatum
metadata []
              tx :: Tx era
tx =
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
scriptInput]
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
collateralInput]
                  forall a b. a -> (a -> b) -> b
& forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
auxDataTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData era
auxData
          Integer
percentage <-
            forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppCollateralPercentageL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall a. Integral a => a -> Integer
toInteger
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx forall a b. (a -> b) -> a -> b
$ \Tx era
txFixed -> do
            let expectedCollateral :: Coin
expectedCollateral =
                  Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ Tx era
txFixed forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Coin -> Integer
unCoin forall a. Num a => a -> a -> a
* Integer
percentage forall a. Integral a => a -> a -> Ratio a
% Integer
100
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. DeltaCoin -> Coin -> AlonzoUtxoPredFailure era
InsufficientCollateral (Coin -> DeltaCoin
toDeltaCoin Coin
collateral) Coin
expectedCollateral]