{-# 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
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
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]