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

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

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (TooManyExUnits))
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
import Cardano.Ledger.BaseTypes (Mismatch (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Plutus (
  Data (..),
  ExUnits (..),
  hashPlutusScript,
  withSLanguage,
 )
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
import Data.Foldable (for_)
import qualified Data.Map.Strict as Map
import Lens.Micro
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples

spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BBODY" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  [Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall (l :: Language).
  PlutusLanguage l =>
  SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Language -> String
forall a. Show a => a -> String
show Language
lang) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        let
          alwaysSucceedsWithDatumHash :: ScriptHash
alwaysSucceedsWithDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang :: ScriptHash
          alwaysFailsWithDatumHash :: ScriptHash
alwaysFailsWithDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash
          alwaysSucceedsNoDatumHash :: ScriptHash
alwaysSucceedsNoDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
slang :: ScriptHash
          alwaysFailsNoDatumHash :: ScriptHash
alwaysFailsNoDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash
          evenRedeemerNoDatumHash :: ScriptHash
evenRedeemerNoDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage l
slang :: ScriptHash

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"succeeds with eight Plutus scripts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          rewardAccount <- Credential Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era RewardAccount
registerStakeCredential (Credential Staking -> ImpTestM era RewardAccount)
-> Credential Staking -> ImpTestM era RewardAccount
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
evenRedeemerNoDatumHash
          txCert <- genUnRegTxCert $ ScriptHashObj evenRedeemerNoDatumHash

          withTxsInBlock_ $ do
            impAnn "notValidatingTx" $ do
              txIn <- produceScript alwaysFailsWithDatumHash
              submitPhase2Invalid_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
            impAnn "validatingTx" $ do
              txIn <- produceScript alwaysSucceedsWithDatumHash
              submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]

            impAnn "notValidatingTxWithMint" $ do
              submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
            impAnn "validatingTxWithMint" $ do
              submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash

            maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL

            let dex Integer
i = (Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
i, ExUnits
maxExUnits)
                rPurpose = AsIx Word32 RewardAccount -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 RewardAccount -> PlutusPurpose f era
forall (f :: * -> * -> *).
f Word32 RewardAccount -> PlutusPurpose f era
mkRewardingPurpose (Word32 -> AsIx Word32 RewardAccount
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
                cPurpose = AsIx Word32 (TxCert era) -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
forall (f :: * -> * -> *).
f Word32 (TxCert era) -> PlutusPurpose f era
mkCertifyingPurpose (Word32 -> AsIx Word32 (TxCert era)
forall ix it. ix -> AsIx ix it
AsIx Word32
0)

            impAnn "notValidatingTxWithWithdrawal" $ do
              submitPhase2Invalid_ $
                mkBasicTx mkBasicTxBody
                  & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 1)
            impAnn "validatingTxWithWithdrawal" $ do
              submitTx_ $
                mkBasicTx mkBasicTxBody
                  & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 0)

            impAnn "notValidatingTxWithCert" $ do
              submitPhase2Invalid_ $
                mkBasicTx mkBasicTxBody
                  & bodyTxL . certsTxBodyL .~ [txCert]
                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 1)
            impAnn "validatingTxWithCert" $ do
              submitTx_ $
                mkBasicTx mkBasicTxBody
                  & bodyTxL . certsTxBodyL .~ [txCert]
                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 0)

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"enforces ppMaxBlockExUnits" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          maxBlockUnits <- SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits)
-> SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((ExUnits -> Const r ExUnits)
    -> EpochState era -> Const r (EpochState era))
-> (ExUnits -> Const r ExUnits)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((ExUnits -> Const r ExUnits)
    -> PParams era -> Const r (PParams era))
-> (ExUnits -> Const r ExUnits)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExUnits -> Const r ExUnits)
-> PParams era -> Const r (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL
          maxTxUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL

          let
            ExUnits bMem bSteps = maxBlockUnits
            ExUnits tMem tSteps = maxTxUnits
            txCount = Nat
1 Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat -> Nat -> Nat
forall a. Ord a => a -> a -> a
max (Nat
bMem Nat -> Nat -> Nat
forall a. Integral a => a -> a -> a
`div` Nat
tMem) (Nat
bSteps Nat -> Nat -> Nat
forall a. Integral a => a -> a -> a
`div` Nat
tSteps)
            mismatch =
              Mismatch
                { mismatchExpected :: ExUnits
mismatchExpected = ExUnits
maxBlockUnits
                , mismatchSupplied :: ExUnits
mismatchSupplied = Nat -> Nat -> ExUnits
ExUnits (Nat
txCount Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
* Nat
tMem) (Nat
txCount Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
* Nat
tSteps)
                }

          txIns <- replicateM (fromIntegral txCount) $ produceScript alwaysSucceedsWithDatumHash

          let
            purpose = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
            dex = (Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
0), ExUnits
maxTxUnits)
            buildTxs =
              [TxIn]
-> (TxIn -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TxIn]
txIns ((TxIn -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ())
-> (TxIn -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn ->
                Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
                    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
purpose (Data era, ExUnits)
dex

          withTxsInFailingBlock
            buildTxs
            [injectFailure $ TooManyExUnits mismatch]