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

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Block (
  BlockHeaderVersionInfo (..),
  prevNonceBlockHeaderL,
  versionInfoBlockHeaderL,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.BlockBody (DijkstraEraBlockBody (..))
import Cardano.Ledger.Dijkstra.Rules (DijkstraBbodyPredFailure (..))
import Lens.Micro ((%~), (.~), (^.))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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
"PerasCertValidationFailed" (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
    perasCert <- arbitrary
    withTxsInModifiedFailingBlockM
      (modifyBlockBody protVer $ perasCertBlockBodyL .~ SJust perasCert)
      (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
          [ DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era)
-> DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall a b. (a -> b) -> a -> b
$
              PerasCert -> Nonce -> DijkstraBbodyPredFailure era
forall era. PerasCert -> Nonce -> DijkstraBbodyPredFailure era
PerasCertValidationFailed PerasCert
perasCert (Nonce -> DijkstraBbodyPredFailure era)
-> Nonce -> DijkstraBbodyPredFailure era
forall a b. (a -> b) -> a -> b
$
                Block TestBlockHeader era
block Block TestBlockHeader era
-> Getting Nonce (Block TestBlockHeader era) Nonce -> Nonce
forall s a. s -> Getting a s a -> a
^. Getting Nonce (Block TestBlockHeader era) Nonce
forall h era.
LeiosEraBlockHeader h era =>
Lens' (Block h era) Nonce
Lens' (Block TestBlockHeader era) Nonce
prevNonceBlockHeaderL
          ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HeaderProtVerTooLow" (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 curMajor _ <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    withTxsInModifiedFailingBlockM
      ( versionInfoBlockHeaderL
          %~ \BlockHeaderVersionInfo
versionInfo ->
            BlockHeaderVersionInfo
versionInfo
              { bhviHighestSupportedMajorVersion =
                  pred $ bhviHighestSupportedMajorVersion versionInfo
              }
      )
      (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
          [ DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era)
-> DijkstraBbodyPredFailure era -> EraRuleFailure "BBODY" era
forall a b. (a -> b) -> a -> b
$
              Mismatch RelGTEQ Word32 -> DijkstraBbodyPredFailure era
forall era. Mismatch RelGTEQ Word32 -> DijkstraBbodyPredFailure era
HeaderProtVerTooLow
                Mismatch
                  { mismatchSupplied :: Word32
mismatchSupplied =
                      BlockHeaderVersionInfo -> Word32
bhviHighestSupportedMajorVersion (BlockHeaderVersionInfo -> Word32)
-> BlockHeaderVersionInfo -> Word32
forall a b. (a -> b) -> a -> b
$ Block TestBlockHeader era
block Block TestBlockHeader era
-> Getting
     BlockHeaderVersionInfo
     (Block TestBlockHeader era)
     BlockHeaderVersionInfo
-> BlockHeaderVersionInfo
forall s a. s -> Getting a s a -> a
^. Getting
  BlockHeaderVersionInfo
  (Block TestBlockHeader era)
  BlockHeaderVersionInfo
forall h era.
LeiosEraBlockHeader h era =>
Lens' (Block h era) BlockHeaderVersionInfo
Lens' (Block TestBlockHeader era) BlockHeaderVersionInfo
versionInfoBlockHeaderL
                  , mismatchExpected :: Word32
mismatchExpected = Version -> Word32
getVersion32 Version
curMajor
                  }
          ]