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

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

import Cardano.Crypto.Leios (LeiosCert)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Block (
  BlockHeaderVersionInfo (..),
  blockBodyContainsLeiosCertBlockHeaderL,
  blockHeaderHashBlockHeaderG,
  ebReferencesAnnouncementBlockHeaderL,
  prevNonceBlockHeaderL,
  slotNoBlockHeaderL,
  versionInfoBlockHeaderL,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.BlockBody (DijkstraEraBlockBody (..))
import Cardano.Ledger.Dijkstra.Rules (DijkstraBbodyPredFailure (..))
import Cardano.Ledger.Shelley.LedgerState (esLStateL, lsLastEbAnnouncementL, nesEsL)
import Cardano.Ledger.State (EbAnnouncement (..))
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)
      (submitAnyTx_ $ 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
              }
      )
      (submitAnyTx_ $ 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
                  }
          ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"EB announcement" (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
      announceEb :: EbReferencesAnnouncement -> Block h era -> Block h era
announceEb EbReferencesAnnouncement
ebRefsAnn = (StrictMaybe EbReferencesAnnouncement
 -> Identity (StrictMaybe EbReferencesAnnouncement))
-> Block h era -> Identity (Block h era)
forall h era.
LeiosEraBlockHeader h era =>
Lens' (Block h era) (StrictMaybe EbReferencesAnnouncement)
Lens' (Block h era) (StrictMaybe EbReferencesAnnouncement)
ebReferencesAnnouncementBlockHeaderL ((StrictMaybe EbReferencesAnnouncement
  -> Identity (StrictMaybe EbReferencesAnnouncement))
 -> Block h era -> Identity (Block h era))
-> StrictMaybe EbReferencesAnnouncement
-> Block h era
-> Block h era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EbReferencesAnnouncement -> StrictMaybe EbReferencesAnnouncement
forall a. a -> StrictMaybe a
SJust EbReferencesAnnouncement
ebRefsAnn
      expectLastEbAnnouncement :: Block h era -> EbReferencesAnnouncement -> ImpM (LedgerSpec era) ()
expectLastEbAnnouncement Block h era
block EbReferencesAnnouncement
ebRefsAnn =
        SimpleGetter (NewEpochState era) (StrictMaybe EbAnnouncement)
-> ImpTestM era (StrictMaybe EbAnnouncement)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((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))
-> ((StrictMaybe EbAnnouncement
     -> Const r (StrictMaybe EbAnnouncement))
    -> EpochState era -> Const r (EpochState era))
-> (StrictMaybe EbAnnouncement
    -> Const r (StrictMaybe EbAnnouncement))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((StrictMaybe EbAnnouncement
     -> Const r (StrictMaybe EbAnnouncement))
    -> LedgerState era -> Const r (LedgerState era))
-> (StrictMaybe EbAnnouncement
    -> Const r (StrictMaybe EbAnnouncement))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe EbAnnouncement
 -> Const r (StrictMaybe EbAnnouncement))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe EbAnnouncement -> f (StrictMaybe EbAnnouncement))
-> LedgerState era -> f (LedgerState era)
lsLastEbAnnouncementL)
          ImpTestM era (StrictMaybe EbAnnouncement)
-> StrictMaybe EbAnnouncement -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` EbAnnouncement -> StrictMaybe EbAnnouncement
forall a. a -> StrictMaybe a
SJust
            EbAnnouncement
              { ebAnnouncement :: EbReferencesAnnouncement
ebAnnouncement = EbReferencesAnnouncement
ebRefsAnn
              , ebAnnouncementSlotNo :: SlotNo
ebAnnouncementSlotNo = Block h era
block Block h era -> Getting SlotNo (Block h era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (Block h era) SlotNo
forall h era. EraBlockHeader h era => Lens' (Block h era) SlotNo
Lens' (Block h era) SlotNo
slotNoBlockHeaderL
              , ebAnnouncedInBlockHeader :: SafeHash EraIndependentBlockHeader
ebAnnouncedInBlockHeader = Block h era
block Block h era
-> Getting
     (SafeHash EraIndependentBlockHeader)
     (Block h era)
     (SafeHash EraIndependentBlockHeader)
-> SafeHash EraIndependentBlockHeader
forall s a. s -> Getting a s a -> a
^. Getting
  (SafeHash EraIndependentBlockHeader)
  (Block h era)
  (SafeHash EraIndependentBlockHeader)
SimpleGetter (Block h era) (SafeHash EraIndependentBlockHeader)
forall h era.
EraBlockHeader h era =>
SimpleGetter (Block h era) (SafeHash EraIndependentBlockHeader)
blockHeaderHashBlockHeaderG
              }

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Records the announcement made in the block header" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ebRefsAnn <- ImpM (LedgerSpec era) EbReferencesAnnouncement
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      block <- withTxsInModifiedBlock (announceEb ebRefsAnn) (pure ())
      expectLastEbAnnouncement block ebRefsAnn

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Replaces it with a newer announcement" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ebRefsAnn1 <- ImpM (LedgerSpec era) EbReferencesAnnouncement
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      _ <- withTxsInModifiedBlock (announceEb ebRefsAnn1) (pure ())
      passTick
      ebRefsAnn2 <- arbitrary
      block2 <- withTxsInModifiedBlock (announceEb ebRefsAnn2) (pure ())
      expectLastEbAnnouncement block2 ebRefsAnn2

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Clears it when a later block announces nothing" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ebRefsAnn <- ImpM (LedgerSpec era) EbReferencesAnnouncement
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      block <- withTxsInModifiedBlock (announceEb ebRefsAnn) (pure ())
      expectLastEbAnnouncement block ebRefsAnn
      passTick
      withTxsInBlock_ (pure ())
      getsNES (nesEsL . esLStateL . lsLastEbAnnouncementL) `shouldReturn` SNothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Records the announcement of a block that certifies an EB" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cert <- ImpTestM era LeiosCert
forall era. DijkstraEraImp era => ImpTestM era LeiosCert
announceCertifiableEb
      replicateM_ 14 passTick
      protVer <- getProtVer
      ebRefsAnn <- arbitrary
      block <-
        withTxsInModifiedBlock
          (announceEb ebRefsAnn . modifyBlockBody protVer (leiosCertBlockBodyL .~ SJust cert))
          (pure ())
      expectLastEbAnnouncement block ebRefsAnn

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertMissing"
    (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ (Block TestBlockHeader era -> Block TestBlockHeader era)
-> ImpM (LedgerSpec era) ()
-> (Block TestBlockHeader era
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "BBODY" era))))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(Block TestBlockHeader era -> Block TestBlockHeader era)
-> ImpTestM era ()
-> (Block TestBlockHeader era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "BBODY" era))))
-> ImpTestM era ()
withTxsInModifiedFailingBlockM
      ((Bool -> Identity Bool)
-> Block TestBlockHeader era
-> Identity (Block TestBlockHeader era)
forall h era. LeiosEraBlockHeader h era => Lens' (Block h era) Bool
Lens' (Block TestBlockHeader era) Bool
blockBodyContainsLeiosCertBlockHeaderL ((Bool -> Identity Bool)
 -> Block TestBlockHeader era
 -> Identity (Block TestBlockHeader era))
-> Bool -> Block TestBlockHeader era -> Block TestBlockHeader era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True)
      ((forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody)
    ((Block TestBlockHeader era
  -> ImpM
       (LedgerSpec era)
       (NonEmpty (PredicateFailure (EraRule "BBODY" era))))
 -> ImpM (LedgerSpec era) ())
-> (Block TestBlockHeader era
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "BBODY" era))))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Block TestBlockHeader era
_ -> 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
forall era. DijkstraBbodyPredFailure era
LeiosCertMissing]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertBlockBodyHasTxs" (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
    leiosCert <- arbitrary
    withTxsInModifiedFailingBlockM
      (modifyBlockBody protVer $ leiosCertBlockBodyL .~ SJust leiosCert)
      (submitAnyTx_ $ mkBasicTx mkBasicTxBody)
      $ \Block TestBlockHeader era
_ -> 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
forall era. DijkstraBbodyPredFailure era
LeiosCertBlockBodyHasTxs]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertWithoutEbAnnouncement" (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
    leiosCert <- arbitrary
    withTxsInModifiedFailingBlockM
      (modifyBlockBody protVer $ leiosCertBlockBodyL .~ SJust leiosCert)
      (pure ())
      $ \Block TestBlockHeader era
_ -> 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
forall era. DijkstraBbodyPredFailure era
LeiosCertWithoutEbAnnouncement]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Cannot certify the same EB twice" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    cert <- ImpTestM era LeiosCert
forall era. DijkstraEraImp era => ImpTestM era LeiosCert
announceCertifiableEb
    replicateM_ 14 passTick
    protVer <- getProtVer
    let certify = ProtVer
-> (BlockBody era -> BlockBody era)
-> Block TestBlockHeader era
-> Block TestBlockHeader era
forall era.
EraBlockBody era =>
ProtVer
-> (BlockBody era -> BlockBody era)
-> Block TestBlockHeader era
-> Block TestBlockHeader era
modifyBlockBody ProtVer
protVer ((BlockBody era -> BlockBody era)
 -> Block TestBlockHeader era -> Block TestBlockHeader era)
-> (BlockBody era -> BlockBody era)
-> Block TestBlockHeader era
-> Block TestBlockHeader era
forall a b. (a -> b) -> a -> b
$ (StrictMaybe LeiosCert -> Identity (StrictMaybe LeiosCert))
-> BlockBody era -> Identity (BlockBody era)
forall era.
DijkstraEraBlockBody era =>
Lens' (BlockBody era) (StrictMaybe LeiosCert)
Lens' (BlockBody era) (StrictMaybe LeiosCert)
leiosCertBlockBodyL ((StrictMaybe LeiosCert -> Identity (StrictMaybe LeiosCert))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictMaybe LeiosCert -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LeiosCert -> StrictMaybe LeiosCert
forall a. a -> StrictMaybe a
SJust LeiosCert
cert
    _ <- withTxsInModifiedBlock certify (pure ())
    passTick
    withTxsInModifiedFailingBlockM certify (pure ()) $
      \Block TestBlockHeader era
_ -> 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
forall era. DijkstraBbodyPredFailure era
LeiosCertWithoutEbAnnouncement]

-- | Seats a Leios committee, announces an EB and certifies it with enough votes for the quorum.
-- The certificate can be included 14 slots later.
announceCertifiableEb :: DijkstraEraImp era => ImpTestM era LeiosCert
announceCertifiableEb :: forall era. DijkstraEraImp era => ImpTestM era LeiosCert
announceCertifiableEb = do
  signKeys <- Int -> ImpTestM era [LeiosSigningKey]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [LeiosSigningKey]
setupLeiosCommittee Int
4
  ebRefsAnn <- arbitrary
  block <- withTxsInModifiedBlock (ebReferencesAnnouncementBlockHeaderL .~ SJust ebRefsAnn) (pure ())
  mkLeiosCert (take 3 signKeys) $ block ^. blockHeaderHashBlockHeaderG