{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Chain.Byron.API (
  genApplyMempoolPayloadErr,
  ts_mempoolValidation,
  ts_roundTripApplyMempoolPayloadErrCompat,
  ts_scheduledDelegations,
  tests,
)
where

import qualified Byron.Spec.Chain.STS.Block as STS
import Byron.Spec.Chain.STS.Rule.Chain (CHAIN)
import qualified Byron.Spec.Chain.STS.Rule.Epoch as STS
import qualified Byron.Spec.Chain.STS.Rule.SigCnt as STS
import qualified Byron.Spec.Ledger.Core as Spec
import qualified Byron.Spec.Ledger.Delegation as Spec
import qualified Byron.Spec.Ledger.STS.UTXO as STS
import qualified Byron.Spec.Ledger.STS.UTXOW as STS
import qualified Byron.Spec.Ledger.Update as Spec
import Cardano.Chain.Block (
  BlockValidationMode (..),
  ChainValidationError (..),
  ChainValidationState (..),
  HeaderHash,
  initialChainValidationState,
 )
import Cardano.Chain.Byron.API (
  ApplyMempoolPayloadErr (..),
  applyChainTick,
  applyMempoolPayload,
  getDelegationMap,
  previewDelegationMap,
  reAnnotateUsing,
  validateBlock,
 )
import Cardano.Chain.Genesis (configSlotSecurityParam)
import qualified Cardano.Chain.Genesis as Genesis
import Cardano.Chain.MempoolPayload (AMempoolPayload (..), MempoolPayload)
import Cardano.Chain.Slotting (SlotCount (..), SlotNumber (..))
import Cardano.Chain.UTxO (TxValidationMode (..))
import Cardano.Chain.ValidationMode (ValidationMode (..))
import Cardano.Crypto (ProtocolMagicId)
import qualified Cardano.Crypto.Hashing as H
import Cardano.Ledger.Binary (decCBOR, encCBOR)
import Cardano.Prelude
import qualified Control.State.Transition as STS
import Data.Coerce (coerce)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Hedgehog (Gen, Group (..), annotateShow, forAll, property, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Cardano.Chain.Block.Model (elaborateAndUpdate, elaborateBlock)
import qualified Test.Cardano.Chain.Delegation.Gen as Dlg
import Test.Cardano.Chain.Elaboration.Block (
  AbstractToConcreteIdMaps (..),
  abEnvToCfg,
 )
import Test.Cardano.Chain.Elaboration.Delegation (elaborateDCert)
import Test.Cardano.Chain.Elaboration.Update (elaborateUpdateProposal, elaborateVote)
import Test.Cardano.Chain.UTxO.Gen (genUTxOValidationError)
import Test.Cardano.Chain.UTxO.Model (
  elaborateInitialUTxO,
  elaborateTxWitsBSWithMap,
 )
import qualified Test.Cardano.Chain.Update.Gen as UpdateIface
import Test.Cardano.Crypto.Gen (feedPM)
import Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (roundTripsCBORShow)
import qualified Test.Control.State.Transition.Generator as STS
import qualified Test.Control.State.Transition.Trace as STS
import Test.Options (TSGroup, TSProperty, eachOfTS, withTestsTS)

tests :: TSGroup
tests :: TSGroup
tests TestScenario
scenario =
  GroupName -> [(PropertyName, Property)] -> Group
Group
    GroupName
"Test.Cardano.Chain.Byron.API"
    [ (PropertyName
"ts_chainTick", TSProperty
ts_chainTick TestScenario
scenario)
    , (PropertyName
"ts_roundTripApplyMempoolPayloadErrCompat", TSProperty
ts_roundTripApplyMempoolPayloadErrCompat TestScenario
scenario)
    , (PropertyName
"ts_scheduledDelegations", TSProperty
ts_scheduledDelegations TestScenario
scenario)
    , (PropertyName
"ts_mempoolValidation", TSProperty
ts_mempoolValidation TestScenario
scenario)
    ]

ts_roundTripApplyMempoolPayloadErrCompat :: TSProperty
ts_roundTripApplyMempoolPayloadErrCompat :: TSProperty
ts_roundTripApplyMempoolPayloadErrCompat =
  forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
    TestLimit
20
    (forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen ApplyMempoolPayloadErr
genApplyMempoolPayloadErr)
    forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

genApplyMempoolPayloadErr :: ProtocolMagicId -> Gen ApplyMempoolPayloadErr
genApplyMempoolPayloadErr :: ProtocolMagicId -> Gen ApplyMempoolPayloadErr
genApplyMempoolPayloadErr ProtocolMagicId
pm =
  forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
    [ UTxOValidationError -> ApplyMempoolPayloadErr
MempoolTxErr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen UTxOValidationError
genUTxOValidationError
    , Error -> ApplyMempoolPayloadErr
MempoolDlgErr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Error
Dlg.genError
    , Error -> ApplyMempoolPayloadErr
MempoolUpdateProposalErr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> Gen Error
UpdateIface.genError ProtocolMagicId
pm
    , Error -> ApplyMempoolPayloadErr
MempoolUpdateVoteErr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> Gen Error
UpdateIface.genError ProtocolMagicId
pm
    ]

setupChainValidationState ::
  STS.Trace CHAIN ->
  (ChainValidationState, Genesis.Config, AbstractToConcreteIdMaps)
setupChainValidationState :: Trace CHAIN
-> (ChainValidationState, Config, AbstractToConcreteIdMaps)
setupChainValidationState Trace CHAIN
sampleTrace =
  let chainEnv :: Environment CHAIN
chainEnv@(Slot
_, UTxO
abstractInitialUTxO, Set VKeyGenesis
_, PParams
_, BlockCount
_) = forall s. Trace s -> Environment s
STS._traceEnv Trace CHAIN
sampleTrace
      config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
chainEnv
      (UTxO
initialUTxO, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractInitialUTxO
      initialAbstractToConcreteIdMaps :: AbstractToConcreteIdMaps
initialAbstractToConcreteIdMaps = forall a. Monoid a => a
mempty {transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
txIdMap}
      initialStateNoUTxO :: ChainValidationState
initialStateNoUTxO = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> a
panic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Show a, ConvertText String b) => a -> b
show) forall (cat :: * -> * -> *) a. Category cat => cat a a
identity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config
      initialState :: ChainValidationState
initialState = ChainValidationState
initialStateNoUTxO {$sel:cvsUtxo:ChainValidationState :: UTxO
cvsUtxo = UTxO
initialUTxO}
      (ChainValidationState
cvs, AbstractToConcreteIdMaps
abstractToConcreteIdMaps) =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> a
panic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Show a, ConvertText String b) => a -> b
show) forall (cat :: * -> * -> *) a. Category cat => cat a a
identity
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
            (Config
-> (ChainValidationState, AbstractToConcreteIdMaps)
-> (State CHAIN, Block)
-> Either
     ChainValidationError
     (ChainValidationState, AbstractToConcreteIdMaps)
elaborateAndUpdate Config
config)
            (ChainValidationState
initialState, AbstractToConcreteIdMaps
initialAbstractToConcreteIdMaps)
            (forall s. TraceOrder -> Trace s -> [(State s, Signal s)]
STS.preStatesAndSignals TraceOrder
STS.OldestFirst Trace CHAIN
sampleTrace)
   in (ChainValidationState
cvs, Config
config, AbstractToConcreteIdMaps
abstractToConcreteIdMaps)

-- | getDelegationMap . applyChainTick slot == previewDelegationMap slot
ts_scheduledDelegations :: TSProperty
ts_scheduledDelegations :: TSProperty
ts_scheduledDelegations = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
100 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall s. HasTrace s => BaseEnv s -> Word64 -> Gen (Trace s)
STS.trace @CHAIN () Word64
traceLength
  let (ChainValidationState
cvs, Config
config, AbstractToConcreteIdMaps
_) = Trace CHAIN
-> (ChainValidationState, Config, AbstractToConcreteIdMaps)
setupChainValidationState Trace CHAIN
sampleTrace
      n :: Word64
n = SlotNumber -> Word64
unSlotNumber forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationState -> SlotNumber
cvsLastSlot forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      k :: Word64
k = SlotCount -> Word64
unSlotCount forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> SlotCount
configSlotSecurityParam forall a b. (a -> b) -> a -> b
$ Config
config
  SlotNumber
slotNumber <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNumber
SlotNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (forall a. Integral a => a -> a -> Range a
Range.linear Word64
n (Word64
n forall a. Num a => a -> a -> a
+ Word64
2 forall a. Num a => a -> a -> a
* Word64
k forall a. Num a => a -> a -> a
- Word64
1))
  let tickedDelegationMap :: Map
tickedDelegationMap = ChainValidationState -> Map
getDelegationMap forall a b. (a -> b) -> a -> b
$ Config
-> SlotNumber -> ChainValidationState -> ChainValidationState
applyChainTick Config
config SlotNumber
slotNumber ChainValidationState
cvs
      anachronisticDelegationMap :: Map
anachronisticDelegationMap = SlotNumber -> ChainValidationState -> Map
previewDelegationMap SlotNumber
slotNumber ChainValidationState
cvs
  Map
tickedDelegationMap forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Map
anachronisticDelegationMap

-- | Given three slots, a < b < c, ticking from a to b and then b to c
-- | should be the same as ticking from a to c.
ts_chainTick :: TSProperty
ts_chainTick :: TSProperty
ts_chainTick = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
100 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall s. HasTrace s => BaseEnv s -> Word64 -> Gen (Trace s)
STS.trace @CHAIN () Word64
traceLength
  let (ChainValidationState
cvs, Config
config, AbstractToConcreteIdMaps
_) = Trace CHAIN
-> (ChainValidationState, Config, AbstractToConcreteIdMaps)
setupChainValidationState Trace CHAIN
sampleTrace
      n0 :: Word64
n0 = SlotNumber -> Word64
unSlotNumber forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationState -> SlotNumber
cvsLastSlot forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      k :: Word64
k = SlotCount -> Word64
unSlotCount forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> SlotCount
configSlotSecurityParam forall a b. (a -> b) -> a -> b
$ Config
config
  Word64
n2 <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (forall a. Integral a => a -> a -> Range a
Range.linear Word64
n0 (Word64
n0 forall a. Num a => a -> a -> a
+ Word64
2 forall a. Num a => a -> a -> a
* Word64
k))
  Word64
n1 <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (forall a. Integral a => a -> a -> Range a
Range.linear Word64
n0 Word64
n2)
  let tick :: Word64 -> ChainValidationState -> ChainValidationState
tick Word64
n = Config
-> SlotNumber -> ChainValidationState -> ChainValidationState
applyChainTick Config
config (Word64 -> SlotNumber
SlotNumber Word64
n)
  (Word64 -> ChainValidationState -> ChainValidationState
tick Word64
n2 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> ChainValidationState -> ChainValidationState
tick Word64
n1) ChainValidationState
cvs forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Word64 -> ChainValidationState -> ChainValidationState
tick Word64
n2 ChainValidationState
cvs

-- | A transaction should validate in the mempool at a given slot when
--   it validates in a block issued for that same slot.
ts_mempoolValidation :: TSProperty
ts_mempoolValidation :: TSProperty
ts_mempoolValidation = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
100 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall s. HasTrace s => BaseEnv s -> Word64 -> Gen (Trace s)
STS.trace @CHAIN () Word64
traceLength
  let (Spec.Slot Word64
slot, UTxO
utxo0, Set VKeyGenesis
_, PParams
_, BlockCount
blockCount) = forall s. Trace s -> Environment s
STS._traceEnv Trace CHAIN
sampleTrace
      abstractChainState :: State CHAIN
abstractChainState@(Slot
_stateSlot, Seq VKeyGenesis
allowedDelegators, Hash
h, UTxOState
utxoState, DIState
diState, UPIState
upiState) =
        forall s. Trace s -> State s
STS.lastState Trace CHAIN
sampleTrace
      (ChainValidationState
cvs, Config
config, AbstractToConcreteIdMaps
abstractToConcreteIdMaps) = Trace CHAIN
-> (ChainValidationState, Config, AbstractToConcreteIdMaps)
setupChainValidationState Trace CHAIN
sampleTrace
      pm :: ProtocolMagicId
pm = Config -> ProtocolMagicId
Genesis.configProtocolMagicId Config
config
      txIdMap :: Map TxId TxId
txIdMap = AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds AbstractToConcreteIdMaps
abstractToConcreteIdMaps
      upIdMap :: Map UpId UpId
upIdMap = AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds AbstractToConcreteIdMaps
abstractToConcreteIdMaps
  Word64
genSlot <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ (Word64
slot forall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (forall a. Integral a => a -> a -> Range a
Range.linear Word64
1 Word64
20)
  let nextSlot :: Slot
nextSlot = Word64 -> Slot
Spec.Slot Word64
genSlot
      pparams :: PParams
pparams = UPIState -> PParams
Spec.protocolParameters UPIState
upiState
      utxoEnv :: UTxOEnv
utxoEnv = UTxO -> PParams -> UTxOEnv
STS.UTxOEnv UTxO
utxo0 PParams
pparams
  Tx
transaction <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall s. HasTrace s => SignalGenerator s
STS.sigGen @STS.UTXOW UTxOEnv
utxoEnv UTxOState
utxoState
  let txAux :: ATxAux ByteString
txAux = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Map TxId TxId -> Tx -> (ATxAux ByteString, Map TxId TxId)
elaborateTxWitsBSWithMap Map TxId TxId
txIdMap Tx
transaction
      mempoolTx :: AMempoolPayload ByteString
mempoolTx = forall a. ATxAux a -> AMempoolPayload a
MempoolTx ATxAux ByteString
txAux

  let dsEnv :: DSEnv
dsEnv =
        Spec.DSEnv
          { _dSEnvAllowedDelegators :: Set VKeyGenesis
Spec._dSEnvAllowedDelegators = forall a. Ord a => [a] -> Set a
Set.fromList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Seq VKeyGenesis
allowedDelegators
          , _dSEnvEpoch :: Epoch
Spec._dSEnvEpoch = HasCallStack => Slot -> BlockCount -> Epoch
STS.sEpoch Slot
nextSlot BlockCount
blockCount
          , _dSEnvSlot :: Slot
Spec._dSEnvSlot = Slot
nextSlot
          , _dSEnvK :: BlockCount
Spec._dSEnvK = BlockCount
blockCount
          }
  Maybe DCert
dcert <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DSEnv -> DIState -> Gen [DCert]
Spec.dcertsGen DSEnv
dsEnv DIState
diState
  let mempoolDCert :: Maybe (AMempoolPayload ByteString)
mempoolDCert = AMempoolPayload () -> AMempoolPayload ByteString
addAnnotation forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. ACertificate a -> AMempoolPayload a
MempoolDlg forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DCert
dcert

  let upiEnv :: Spec.UPIEnv
      upiEnv :: UPIEnv
upiEnv =
        ( Slot
nextSlot
        , DIState -> Bimap VKeyGenesis VKey
Spec._dIStateDelegationMap DIState
diState
        , BlockCount
blockCount
        , forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HasLength a => a -> Int
length Seq VKeyGenesis
allowedDelegators
        )
  (Maybe UProp
uProp, [Vote]
vote) <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> [a]
take Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UPIEnv -> UPIState -> GenT Identity (Maybe UProp, [Vote])
Spec.updateProposalAndVotesGen UPIEnv
upiEnv UPIState
upiState

  let mempoolUpdatePropAndVote :: [AMempoolPayload ByteString]
mempoolUpdatePropAndVote = case Maybe UProp
uProp of
        Maybe UProp
Nothing -> []
        Just UProp
up ->
          let up' :: AProposal ()
up' = ProtocolMagicId -> UProp -> AProposal ()
elaborateUpdateProposal ProtocolMagicId
pm UProp
up
              upIdMap' :: Map UpId UpId
upIdMap' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UProp -> UpId
Spec._upId UProp
up) (forall a. EncCBOR a => a -> Hash a
H.serializeCborHash AProposal ()
up') Map UpId UpId
upIdMap
              vote' :: [AVote ()]
vote' = ProtocolMagicId -> Map UpId UpId -> Vote -> AVote ()
elaborateVote ProtocolMagicId
pm Map UpId UpId
upIdMap' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vote]
vote
           in AMempoolPayload () -> AMempoolPayload ByteString
addAnnotation
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. AProposal a -> AMempoolPayload a
MempoolUpdateProposal AProposal ()
up']
                forall a. Semigroup a => a -> a -> a
<> (forall a. AVote a -> AMempoolPayload a
MempoolUpdateVote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AVote ()]
vote')

  let mempoolPayloads :: [AMempoolPayload ByteString]
mempoolPayloads =
        [AMempoolPayload ByteString
mempoolTx]
          forall a. Semigroup a => a -> a -> a
<> [AMempoolPayload ByteString]
mempoolUpdatePropAndVote
          forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList Maybe (AMempoolPayload ByteString)
mempoolDCert

  VKey
issuerKey <-
    let env :: STS.Environment STS.SIGCNT
        env :: Environment SIGCNT
env =
          ( PParams
pparams
          , DIState -> Bimap VKeyGenesis VKey
Spec._dIStateDelegationMap DIState
diState
          , BlockCount
blockCount
          )
     in forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ Environment SIGCNT -> State SIGCNT -> Gen VKey
STS.issuer Environment SIGCNT
env Seq VKeyGenesis
allowedDelegators
  ProtVer
aBlockVersion <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ UPIEnv -> UPIState -> Gen ProtVer
Spec.protocolVersionEndorsementGen UPIEnv
upiEnv UPIState
upiState
  let abstractBlock :: Block
abstractBlock =
        Hash
-> Slot
-> VKey
-> ProtVer
-> [DCert]
-> Maybe UProp
-> [Vote]
-> [Tx]
-> Block
STS.mkBlock
          Hash
h
          Slot
nextSlot
          VKey
issuerKey
          ProtVer
aBlockVersion
          (forall a. Maybe a -> [a]
maybeToList Maybe DCert
dcert)
          Maybe UProp
uProp
          [Vote]
vote
          [Tx
transaction]
      concreteBlock :: ABlock ByteString
concreteBlock =
        Config
-> ChainValidationState
-> AbstractToConcreteIdMaps
-> State CHAIN
-> Block
-> ABlock ByteString
elaborateBlock
          Config
config
          ChainValidationState
cvs
          AbstractToConcreteIdMaps
abstractToConcreteIdMaps
          (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
abstractChainState
          Block
abstractBlock

  let validationMode :: ValidationMode
validationMode = BlockValidationMode -> TxValidationMode -> ValidationMode
ValidationMode BlockValidationMode
BlockValidation TxValidationMode
TxValidation
      apply1 ::
        ChainValidationState ->
        AMempoolPayload ByteString ->
        Either ApplyMempoolPayloadErr ChainValidationState
      apply1 :: ChainValidationState
-> AMempoolPayload ByteString
-> Either ApplyMempoolPayloadErr ChainValidationState
apply1 ChainValidationState
c AMempoolPayload ByteString
mp = forall (m :: * -> *).
MonadError ApplyMempoolPayloadErr m =>
ValidationMode
-> Config
-> SlotNumber
-> AMempoolPayload ByteString
-> ChainValidationState
-> m ChainValidationState
applyMempoolPayload ValidationMode
validationMode Config
config (Word64 -> SlotNumber
SlotNumber Word64
genSlot) AMempoolPayload ByteString
mp ChainValidationState
c
      headerHash :: HeaderHash
headerHash = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. EncCBOR a => a -> Hash a
H.serializeCborHash (Int
0 :: Int)) :: HeaderHash
      applyMempoolPayloadResult :: Either ApplyMempoolPayloadErr ChainValidationState
applyMempoolPayloadResult = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ChainValidationState
-> AMempoolPayload ByteString
-> Either ApplyMempoolPayloadErr ChainValidationState
apply1 ChainValidationState
cvs [AMempoolPayload ByteString]
mempoolPayloads
      validateBlockResult :: Either ChainValidationError ChainValidationState
validateBlockResult =
        forall (m :: * -> *).
MonadError ChainValidationError m =>
Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> m ChainValidationState
validateBlock Config
config ValidationMode
validationMode ABlock ByteString
concreteBlock HeaderHash
headerHash ChainValidationState
cvs ::
          Either ChainValidationError ChainValidationState

  forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow Either ApplyMempoolPayloadErr ChainValidationState
applyMempoolPayloadResult
  forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow Either ChainValidationError ChainValidationState
validateBlockResult
  forall a b. Either a b -> Bool
isRight Either ChainValidationError ChainValidationState
validateBlockResult forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a b. Either a b -> Bool
isRight Either ApplyMempoolPayloadErr ChainValidationState
applyMempoolPayloadResult
  where
    addAnnotation :: MempoolPayload -> AMempoolPayload ByteString
    addAnnotation :: AMempoolPayload () -> AMempoolPayload ByteString
addAnnotation = forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing forall a. EncCBOR a => a -> Encoding
encCBOR forall a s. DecCBOR a => Decoder s a
decCBOR