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

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

import Cardano.Ledger.BaseTypes (Mismatch (..))
import Cardano.Ledger.Block (
  Block (..),
  blockBodyHashBlockHeaderL,
  blockBodySizeBlockHeaderL,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Rules (
  ShelleyBbodyPredFailure (..),
  ShelleyUtxoPredFailure (..),
 )
import qualified Data.Set.NonEmpty as NES
import Lens.Micro ((%~), (.~), (^.))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ShelleyEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp 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
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"WrongBlockBodySizeBBODY" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    withTxsInModifiedFailingBlockM
      (blockBodySizeBlockHeaderL %~ (+ 1))
      (submitTx_ $ mkBasicTx mkBasicTxBody)
      $ \Block TestBlockHeader era
block ->
        NonEmpty (EraRuleFailure "BBODY" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "BBODY" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era)
-> ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall a b. (a -> b) -> a -> b
$
              Mismatch RelEQ Int -> ShelleyBbodyPredFailure era
forall era. Mismatch RelEQ Int -> ShelleyBbodyPredFailure era
WrongBlockBodySizeBBODY
                Mismatch
                  { mismatchSupplied :: Int
mismatchSupplied = ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
blockBodySize ProtVer
protVer (BlockBody era -> Int) -> BlockBody era -> Int
forall a b. (a -> b) -> a -> b
$ Block TestBlockHeader era -> BlockBody era
forall h era. Block h era -> BlockBody era
blockBody Block TestBlockHeader era
block
                  , mismatchExpected :: Int
mismatchExpected = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ Block TestBlockHeader era
block Block TestBlockHeader era
-> Getting Word32 (Block TestBlockHeader era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Block TestBlockHeader era) Word32
forall h era. EraBlockHeader h era => Lens' (Block h era) Word32
Lens' (Block TestBlockHeader era) Word32
blockBodySizeBlockHeaderL
                  }
          ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"InvalidBodyHashBBODY" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    invalidBodyHash <- ImpM (LedgerSpec era) (Hash HASH EraIndependentBlockBody)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
    withTxsInModifiedFailingBlockM
      (blockBodyHashBlockHeaderL .~ invalidBodyHash)
      (submitTx_ $ mkBasicTx mkBasicTxBody)
      $ \Block TestBlockHeader era
block ->
        NonEmpty (EraRuleFailure "BBODY" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "BBODY" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era)
-> ShelleyBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall a b. (a -> b) -> a -> b
$
              Mismatch RelEQ (Hash HASH EraIndependentBlockBody)
-> ShelleyBbodyPredFailure era
forall era.
Mismatch RelEQ (Hash HASH EraIndependentBlockBody)
-> ShelleyBbodyPredFailure era
InvalidBodyHashBBODY
                Mismatch
                  { mismatchSupplied :: Hash HASH EraIndependentBlockBody
mismatchSupplied = BlockBody era -> Hash HASH EraIndependentBlockBody
forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
hashBlockBody (BlockBody era -> Hash HASH EraIndependentBlockBody)
-> BlockBody era -> Hash HASH EraIndependentBlockBody
forall a b. (a -> b) -> a -> b
$ Block TestBlockHeader era -> BlockBody era
forall h era. Block h era -> BlockBody era
blockBody Block TestBlockHeader era
block
                  , mismatchExpected :: Hash HASH EraIndependentBlockBody
mismatchExpected = Block TestBlockHeader era
block Block TestBlockHeader era
-> Getting
     (Hash HASH EraIndependentBlockBody)
     (Block TestBlockHeader era)
     (Hash HASH EraIndependentBlockBody)
-> Hash HASH EraIndependentBlockBody
forall s a. s -> Getting a s a -> a
^. Getting
  (Hash HASH EraIndependentBlockBody)
  (Block TestBlockHeader era)
  (Hash HASH EraIndependentBlockBody)
forall h era.
EraBlockHeader h era =>
Lens' (Block h era) (Hash HASH EraIndependentBlockBody)
Lens'
  (Block TestBlockHeader era) (Hash HASH EraIndependentBlockBody)
blockBodyHashBlockHeaderL
                  }
          ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LedgersFailure" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    withTxsInModifiedFailingSubsetBlockM
      (modifyBlockBody protVer $ txSeqBlockBodyL %~ \StrictSeq (Tx TopTx era)
txs -> StrictSeq (Tx TopTx era)
txs StrictSeq (Tx TopTx era)
-> StrictSeq (Tx TopTx era) -> StrictSeq (Tx TopTx era)
forall a. Semigroup a => a -> a -> a
<> StrictSeq (Tx TopTx era)
txs)
      (submitTx_ $ mkBasicTx mkBasicTxBody)
      $ \Block TestBlockHeader era
block -> do
        Just badInputs <-
          Maybe (NonEmptySet TxIn)
-> ImpM (LedgerSpec era) (Maybe (NonEmptySet TxIn))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmptySet TxIn)
 -> ImpM (LedgerSpec era) (Maybe (NonEmptySet TxIn)))
-> Maybe (NonEmptySet TxIn)
-> ImpM (LedgerSpec era) (Maybe (NonEmptySet TxIn))
forall a b. (a -> b) -> a -> b
$
            Set TxIn -> Maybe (NonEmptySet TxIn)
forall a. Set a -> Maybe (NonEmptySet a)
NES.fromSet (Set TxIn -> Maybe (NonEmptySet TxIn))
-> Set TxIn -> Maybe (NonEmptySet TxIn)
forall a b. (a -> b) -> a -> b
$
              (Tx TopTx era -> Set TxIn) -> StrictSeq (Tx TopTx era) -> Set TxIn
forall m a. Monoid m => (a -> m) -> StrictSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (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 -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (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) (StrictSeq (Tx TopTx era) -> Set TxIn)
-> StrictSeq (Tx TopTx era) -> Set TxIn
forall a b. (a -> b) -> a -> b
$
                Block TestBlockHeader era -> BlockBody era
forall h era. Block h era -> BlockBody era
blockBody Block TestBlockHeader era
block BlockBody era
-> Getting
     (StrictSeq (Tx TopTx era))
     (BlockBody era)
     (StrictSeq (Tx TopTx era))
-> StrictSeq (Tx TopTx era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (Tx TopTx era))
  (BlockBody era)
  (StrictSeq (Tx TopTx era))
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyL
        pure [injectFailure $ BadInputsUTxO badInputs]