{-# 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 (Mismatch (..), 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 (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era) =>
SpecWith (ImpInit (LedgerSpec 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. Mismatch 'RelEQ Network -> AlonzoUtxoPredFailure era
WrongNetworkInTxBody Mismatch {mismatchSupplied :: Network
mismatchSupplied = Network
Mainnet, mismatchExpected :: Network
mismatchExpected = Network
Testnet}
      ]

  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
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
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 -> 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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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. Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure era
ExUnitsTooBigUTxO Mismatch {mismatchSupplied :: ExUnits
mismatchSupplied = ExUnits
txExUnits, mismatchExpected :: ExUnits
mismatchExpected = ExUnits
maxExUnits}
            ]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Insufficient collateral" forall a b. (a -> b) -> a -> b
$ do
          TxIn
scriptInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          Addr
collateralAddr <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshKeyAddr_
          TxIn
collateralInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
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 -> ImpTestM era (TxOut era)
impLookupUTxO TxIn
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)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn
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)
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn
collateralInput]
                  forall a b. a -> (a -> b) -> b
& forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData 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]