{-# 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 =
  TestLimit
-> Gen ApplyMempoolPayloadErr
-> (ApplyMempoolPayloadErr -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
    TestLimit
20
    ((ProtocolMagicId -> Gen ApplyMempoolPayloadErr)
-> Gen ApplyMempoolPayloadErr
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen ApplyMempoolPayloadErr
genApplyMempoolPayloadErr)
    ApplyMempoolPayloadErr -> PropertyT IO ()
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 =
  [Gen ApplyMempoolPayloadErr] -> Gen ApplyMempoolPayloadErr
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
    [ UTxOValidationError -> ApplyMempoolPayloadErr
MempoolTxErr (UTxOValidationError -> ApplyMempoolPayloadErr)
-> GenT Identity UTxOValidationError -> Gen ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity UTxOValidationError
genUTxOValidationError
    , Error -> ApplyMempoolPayloadErr
MempoolDlgErr (Error -> ApplyMempoolPayloadErr)
-> GenT Identity Error -> Gen ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Error
Dlg.genError
    , Error -> ApplyMempoolPayloadErr
MempoolUpdateProposalErr (Error -> ApplyMempoolPayloadErr)
-> GenT Identity Error -> Gen ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> GenT Identity Error
UpdateIface.genError ProtocolMagicId
pm
    , Error -> ApplyMempoolPayloadErr
MempoolUpdateVoteErr (Error -> ApplyMempoolPayloadErr)
-> GenT Identity Error -> Gen ApplyMempoolPayloadErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> GenT Identity 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
_) = Trace CHAIN -> Environment CHAIN
forall s. Trace s -> Environment s
STS._traceEnv Trace CHAIN
sampleTrace
      config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
Environment CHAIN
chainEnv
      (UTxO
initialUTxO, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractInitialUTxO
      initialAbstractToConcreteIdMaps :: AbstractToConcreteIdMaps
initialAbstractToConcreteIdMaps = AbstractToConcreteIdMaps
forall a. Monoid a => a
mempty {transactionIds = txIdMap}
      initialStateNoUTxO :: ChainValidationState
initialStateNoUTxO = (Error -> ChainValidationState)
-> (ChainValidationState -> ChainValidationState)
-> Either Error ChainValidationState
-> ChainValidationState
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> ChainValidationState
forall a. HasCallStack => Text -> a
panic (Text -> ChainValidationState)
-> (Error -> Text) -> Error -> ChainValidationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Error -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show) ChainValidationState -> ChainValidationState
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (Either Error ChainValidationState -> ChainValidationState)
-> Either Error ChainValidationState -> ChainValidationState
forall a b. (a -> b) -> a -> b
$ Config -> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config
      initialState :: ChainValidationState
initialState = ChainValidationState
initialStateNoUTxO {cvsUtxo = initialUTxO}
      (ChainValidationState
cvs, AbstractToConcreteIdMaps
abstractToConcreteIdMaps) =
        (ChainValidationError
 -> (ChainValidationState, AbstractToConcreteIdMaps))
-> ((ChainValidationState, AbstractToConcreteIdMaps)
    -> (ChainValidationState, AbstractToConcreteIdMaps))
-> Either
     ChainValidationError
     (ChainValidationState, AbstractToConcreteIdMaps)
-> (ChainValidationState, AbstractToConcreteIdMaps)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> (ChainValidationState, AbstractToConcreteIdMaps)
forall a. HasCallStack => Text -> a
panic (Text -> (ChainValidationState, AbstractToConcreteIdMaps))
-> (ChainValidationError -> Text)
-> ChainValidationError
-> (ChainValidationState, AbstractToConcreteIdMaps)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ChainValidationError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show) (ChainValidationState, AbstractToConcreteIdMaps)
-> (ChainValidationState, AbstractToConcreteIdMaps)
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity
          (Either
   ChainValidationError
   (ChainValidationState, AbstractToConcreteIdMaps)
 -> (ChainValidationState, AbstractToConcreteIdMaps))
-> Either
     ChainValidationError
     (ChainValidationState, AbstractToConcreteIdMaps)
-> (ChainValidationState, AbstractToConcreteIdMaps)
forall a b. (a -> b) -> a -> b
$ ((ChainValidationState, AbstractToConcreteIdMaps)
 -> ((Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState),
     Block)
 -> Either
      ChainValidationError
      (ChainValidationState, AbstractToConcreteIdMaps))
-> (ChainValidationState, AbstractToConcreteIdMaps)
-> [((Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState),
     Block)]
-> Either
     ChainValidationError
     (ChainValidationState, AbstractToConcreteIdMaps)
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)
            (TraceOrder -> Trace CHAIN -> [(State CHAIN, Signal CHAIN)]
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 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN))
-> Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
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 (SlotNumber -> Word64)
-> (ChainValidationState -> SlotNumber)
-> ChainValidationState
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (ChainValidationState -> Word64) -> ChainValidationState -> Word64
forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      k :: Word64
k = SlotCount -> Word64
unSlotCount (SlotCount -> Word64) -> (Config -> SlotCount) -> Config -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (Config -> Word64) -> Config -> Word64
forall a b. (a -> b) -> a -> b
$ Config
config
  SlotNumber
slotNumber <- Gen SlotNumber -> PropertyT IO SlotNumber
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen SlotNumber -> PropertyT IO SlotNumber)
-> Gen SlotNumber -> PropertyT IO SlotNumber
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNumber
SlotNumber (Word64 -> SlotNumber) -> GenT Identity Word64 -> Gen SlotNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word64 -> GenT Identity Word64
forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (Word64 -> Word64 -> Range Word64
forall a. Integral a => a -> a -> Range a
Range.linear Word64
n (Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1))
  let tickedDelegationMap :: Map
tickedDelegationMap = ChainValidationState -> Map
getDelegationMap (ChainValidationState -> Map) -> ChainValidationState -> Map
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 Map -> Map -> PropertyT IO ()
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 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN))
-> Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
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 (SlotNumber -> Word64)
-> (ChainValidationState -> SlotNumber)
-> ChainValidationState
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (ChainValidationState -> Word64) -> ChainValidationState -> Word64
forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      k :: Word64
k = SlotCount -> Word64
unSlotCount (SlotCount -> Word64) -> (Config -> SlotCount) -> Config -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (Config -> Word64) -> Config -> Word64
forall a b. (a -> b) -> a -> b
$ Config
config
  Word64
n2 <- GenT Identity Word64 -> PropertyT IO Word64
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (GenT Identity Word64 -> PropertyT IO Word64)
-> GenT Identity Word64 -> PropertyT IO Word64
forall a b. (a -> b) -> a -> b
$ Range Word64 -> GenT Identity Word64
forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (Word64 -> Word64 -> Range Word64
forall a. Integral a => a -> a -> Range a
Range.linear Word64
n0 (Word64
n0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k))
  Word64
n1 <- GenT Identity Word64 -> PropertyT IO Word64
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (GenT Identity Word64 -> PropertyT IO Word64)
-> GenT Identity Word64 -> PropertyT IO Word64
forall a b. (a -> b) -> a -> b
$ Range Word64 -> GenT Identity Word64
forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (Word64 -> Word64 -> Range 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 (ChainValidationState -> ChainValidationState)
-> (ChainValidationState -> ChainValidationState)
-> ChainValidationState
-> ChainValidationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 ChainValidationState -> ChainValidationState -> PropertyT IO ()
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 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  let traceLength :: Word64
traceLength = Word64
10 :: Word64
  Trace CHAIN
sampleTrace <- Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN))
-> Gen (Trace CHAIN) -> PropertyT IO (Trace CHAIN)
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) = Trace CHAIN -> Environment CHAIN
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) =
        Trace CHAIN -> State CHAIN
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 <- GenT Identity Word64 -> PropertyT IO Word64
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (GenT Identity Word64 -> PropertyT IO Word64)
-> GenT Identity Word64 -> PropertyT IO Word64
forall a b. (a -> b) -> a -> b
$ (Word64
slot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+) (Word64 -> Word64) -> GenT Identity Word64 -> GenT Identity Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word64 -> GenT Identity Word64
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Word64 -> Word64 -> Range Word64
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 <- Gen (Signal UTXOW) -> PropertyT IO (Signal UTXOW)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Signal UTXOW) -> PropertyT IO (Signal UTXOW))
-> Gen (Signal UTXOW) -> PropertyT IO (Signal UTXOW)
forall a b. (a -> b) -> a -> b
$ forall s. HasTrace s => SignalGenerator s
STS.sigGen @STS.UTXOW UTxOEnv
Environment UTXOW
utxoEnv UTxOState
State UTXOW
utxoState
  let txAux :: ATxAux ByteString
txAux = (ATxAux ByteString, Map TxId TxId) -> ATxAux ByteString
forall a b. (a, b) -> a
fst ((ATxAux ByteString, Map TxId TxId) -> ATxAux ByteString)
-> (ATxAux ByteString, Map TxId TxId) -> ATxAux ByteString
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 = ATxAux ByteString -> AMempoolPayload ByteString
forall a. ATxAux a -> AMempoolPayload a
MempoolTx ATxAux ByteString
txAux

  let dsEnv :: DSEnv
dsEnv =
        Spec.DSEnv
          { _dSEnvAllowedDelegators :: Set VKeyGenesis
Spec._dSEnvAllowedDelegators = [VKeyGenesis] -> Set VKeyGenesis
forall a. Ord a => [a] -> Set a
Set.fromList ([VKeyGenesis] -> Set VKeyGenesis)
-> (Seq VKeyGenesis -> [VKeyGenesis])
-> Seq VKeyGenesis
-> Set VKeyGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Seq VKeyGenesis -> [VKeyGenesis]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq VKeyGenesis -> Set VKeyGenesis)
-> Seq VKeyGenesis -> Set VKeyGenesis
forall a b. (a -> b) -> a -> b
$ Seq VKeyGenesis
allowedDelegators
          , _dSEnvEpoch :: Epoch
Spec._dSEnvEpoch = HasCallStack => Slot -> BlockCount -> Epoch
Slot -> BlockCount -> Epoch
STS.sEpoch Slot
nextSlot BlockCount
blockCount
          , _dSEnvSlot :: Slot
Spec._dSEnvSlot = Slot
nextSlot
          , _dSEnvK :: BlockCount
Spec._dSEnvK = BlockCount
blockCount
          }
  Maybe DCert
dcert <- Gen (Maybe DCert) -> PropertyT IO (Maybe DCert)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Maybe DCert) -> PropertyT IO (Maybe DCert))
-> Gen (Maybe DCert) -> PropertyT IO (Maybe DCert)
forall a b. (a -> b) -> a -> b
$ [DCert] -> Maybe DCert
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head ([DCert] -> Maybe DCert)
-> GenT Identity [DCert] -> Gen (Maybe DCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DSEnv -> DIState -> GenT Identity [DCert]
Spec.dcertsGen DSEnv
dsEnv DIState
diState
  let mempoolDCert :: Maybe (AMempoolPayload ByteString)
mempoolDCert = AMempoolPayload () -> AMempoolPayload ByteString
addAnnotation (AMempoolPayload () -> AMempoolPayload ByteString)
-> (DCert -> AMempoolPayload ())
-> DCert
-> AMempoolPayload ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ACertificate () -> AMempoolPayload ()
forall a. ACertificate a -> AMempoolPayload a
MempoolDlg (ACertificate () -> AMempoolPayload ())
-> (DCert -> ACertificate ()) -> DCert -> AMempoolPayload ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId -> DCert -> ACertificate ()
elaborateDCert ProtocolMagicId
pm (DCert -> AMempoolPayload ByteString)
-> Maybe DCert -> Maybe (AMempoolPayload ByteString)
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
        , Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Seq VKeyGenesis -> Int
forall a. HasLength a => a -> Int
length Seq VKeyGenesis
allowedDelegators
        )
  (Maybe UProp
uProp, [Vote]
vote) <- Gen (Maybe UProp, [Vote]) -> PropertyT IO (Maybe UProp, [Vote])
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Maybe UProp, [Vote]) -> PropertyT IO (Maybe UProp, [Vote]))
-> Gen (Maybe UProp, [Vote]) -> PropertyT IO (Maybe UProp, [Vote])
forall a b. (a -> b) -> a -> b
$ ([Vote] -> [Vote])
-> (Maybe UProp, [Vote]) -> (Maybe UProp, [Vote])
forall a b. (a -> b) -> (Maybe UProp, a) -> (Maybe UProp, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [Vote] -> [Vote]
forall a. Int -> [a] -> [a]
take Int
1) ((Maybe UProp, [Vote]) -> (Maybe UProp, [Vote]))
-> Gen (Maybe UProp, [Vote]) -> Gen (Maybe UProp, [Vote])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UPIEnv -> UPIState -> Gen (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' = UpId -> UpId -> Map UpId UpId -> Map UpId UpId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UProp -> UpId
Spec._upId UProp
up) (AProposal () -> UpId
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' (Vote -> AVote ()) -> [Vote] -> [AVote ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vote]
vote
           in AMempoolPayload () -> AMempoolPayload ByteString
addAnnotation
                (AMempoolPayload () -> AMempoolPayload ByteString)
-> [AMempoolPayload ()] -> [AMempoolPayload ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AProposal () -> AMempoolPayload ()
forall a. AProposal a -> AMempoolPayload a
MempoolUpdateProposal AProposal ()
up']
                [AMempoolPayload ()]
-> [AMempoolPayload ()] -> [AMempoolPayload ()]
forall a. Semigroup a => a -> a -> a
<> (AVote () -> AMempoolPayload ()
forall a. AVote a -> AMempoolPayload a
MempoolUpdateVote (AVote () -> AMempoolPayload ())
-> [AVote ()] -> [AMempoolPayload ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AVote ()]
vote')

  let mempoolPayloads :: [AMempoolPayload ByteString]
mempoolPayloads =
        [AMempoolPayload ByteString
mempoolTx]
          [AMempoolPayload ByteString]
-> [AMempoolPayload ByteString] -> [AMempoolPayload ByteString]
forall a. Semigroup a => a -> a -> a
<> [AMempoolPayload ByteString]
mempoolUpdatePropAndVote
          [AMempoolPayload ByteString]
-> [AMempoolPayload ByteString] -> [AMempoolPayload ByteString]
forall a. Semigroup a => a -> a -> a
<> Maybe (AMempoolPayload ByteString) -> [AMempoolPayload ByteString]
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 Gen VKey -> PropertyT IO VKey
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen VKey -> PropertyT IO VKey) -> Gen VKey -> PropertyT IO VKey
forall a b. (a -> b) -> a -> b
$ Environment SIGCNT -> State SIGCNT -> Gen VKey
STS.issuer Environment SIGCNT
env Seq VKeyGenesis
State SIGCNT
allowedDelegators
  ProtVer
aBlockVersion <- Gen ProtVer -> PropertyT IO ProtVer
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen ProtVer -> PropertyT IO ProtVer)
-> Gen ProtVer -> PropertyT IO ProtVer
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
          (Maybe DCert -> [DCert]
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)
State CHAIN
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 = ValidationMode
-> Config
-> SlotNumber
-> AMempoolPayload ByteString
-> ChainValidationState
-> Either ApplyMempoolPayloadErr ChainValidationState
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 = Hash Int -> HeaderHash
forall a b. Coercible a b => a -> b
coerce (Int -> Hash Int
forall a. EncCBOR a => a -> Hash a
H.serializeCborHash (Int
0 :: Int)) :: HeaderHash
      applyMempoolPayloadResult :: Either ApplyMempoolPayloadErr ChainValidationState
applyMempoolPayloadResult = (ChainValidationState
 -> AMempoolPayload ByteString
 -> Either ApplyMempoolPayloadErr ChainValidationState)
-> ChainValidationState
-> [AMempoolPayload ByteString]
-> Either ApplyMempoolPayloadErr ChainValidationState
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 =
        Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> Either ChainValidationError ChainValidationState
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

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