{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Chain.Block.ValidationMode (
  tests,
) where

import qualified Byron.Spec.Chain.STS.Block as Abstract
import Byron.Spec.Chain.STS.Rule.Chain (CHAIN)
import qualified Byron.Spec.Chain.STS.Rule.Chain as Abstract
import qualified Byron.Spec.Ledger.Core as Abstract
import Byron.Spec.Ledger.Delegation (
  ADELEGS,
  DELEG,
  DIState (..),
  DState (..),
 )
import Byron.Spec.Ledger.GlobalParams (lovelaceCap)
import Byron.Spec.Ledger.STS.UTXO (UTxOEnv (..), UTxOState (..))
import Byron.Spec.Ledger.STS.UTXOWS (UTXOWS)
import qualified Byron.Spec.Ledger.UTxO as Abstract
import Cardano.Chain.Block (
  ABlock (..),
  AHeader (..),
  BlockValidationMode (..),
  Proof (..),
  blockProof,
  initialChainValidationState,
  updateBlock,
 )
import Cardano.Chain.Delegation as Delegation
import Cardano.Chain.UTxO (TxProof)
import Cardano.Chain.ValidationMode (
  ValidationMode (..),
  fromBlockValidationMode,
 )
import Cardano.Crypto (Hash)
import Cardano.Ledger.Binary (Annotated (..))
import Cardano.Prelude hiding (State, trace)
import Control.State.Transition
import qualified Data.Bimap as BM
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Lens.Micro ((^.))
import qualified Test.Cardano.Chain.Delegation.Gen as Delegation
import Test.Cardano.Chain.Elaboration.Block (
  abEnvToCfg,
  elaborateBS,
  rcDCert,
  transactionIds,
 )
import Test.Cardano.Chain.UTxO.Gen (genTxProof)
import Test.Cardano.Chain.UTxO.Model (elaborateInitialUTxO)
import qualified Test.Cardano.Chain.Update.Gen as Update
import Test.Cardano.Crypto.Gen (feedPM, genAbstractHash)
import Test.Cardano.Prelude
import Test.Control.State.Transition.Generator (trace)
import qualified Test.Control.State.Transition.Trace as Trace
import Test.Options (TSGroup, TSProperty, withTestsTS)

--------------------------------------------------------------------------------
-- BlockValidationMode Properties
--------------------------------------------------------------------------------

-- | Property: When calling 'updateBlock' given a valid 'Block', validation
-- should pass in all 'BlockValidationMode's.
ts_prop_updateBlock_Valid :: TSProperty
ts_prop_updateBlock_Valid :: TSProperty
ts_prop_updateBlock_Valid =
  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 -- TODO: check that the @k@ value is not important
      -- in this test, in that case we can get away with
      -- generating small traces.
      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)
trace @CHAIN () Word64
traceLength
      let lastState :: State CHAIN
lastState = Trace CHAIN -> State CHAIN
forall s. Trace s -> State s
Trace.lastState Trace CHAIN
sampleTrace
          chainEnv :: Environment CHAIN
chainEnv@( Slot
_currentSlot
                     , UTxO
abstractInitialUTxO
                     , Set VKeyGenesis
_allowedDelegators
                     , PParams
_protocolParamaters
                     , BlockCount
stableAfter
                     ) = Trace CHAIN -> Environment CHAIN
forall s. Trace s -> Environment s
Trace._traceEnv Trace CHAIN
sampleTrace
      Block
abstractBlock <-
        Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          (Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN))
-> Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN)
forall a b. (a -> b) -> a -> b
$ ShouldGenDelegation
-> ShouldGenUTxO
-> ShouldGenUpdate
-> Environment CHAIN
-> State CHAIN
-> Gen (Signal CHAIN)
Abstract.sigGenChain
            ShouldGenDelegation
Abstract.NoGenDelegation
            ShouldGenUTxO
Abstract.NoGenUTxO
            ShouldGenUpdate
Abstract.NoGenUpdate
            (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
Environment CHAIN
chainEnv
            (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
State CHAIN
lastState
      let config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
Environment CHAIN
chainEnv
          cvs :: ChainValidationState
cvs = (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
a -> ChainValidationState
a) (Config -> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config)
          (UTxO
_, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractInitialUTxO
          dCert :: DCert
dCert =
            HasCallStack => VKey -> BlockCount -> State CHAIN -> DCert
VKey -> BlockCount -> State CHAIN -> DCert
rcDCert
              (Block
abstractBlock Block -> Getting VKey Block VKey -> VKey
forall s a. s -> Getting a s a -> a
^. (BlockHeader -> Const VKey BlockHeader)
-> Block -> Const VKey Block
Lens' Block BlockHeader
Abstract.bHeader ((BlockHeader -> Const VKey BlockHeader)
 -> Block -> Const VKey Block)
-> ((VKey -> Const VKey VKey)
    -> BlockHeader -> Const VKey BlockHeader)
-> Getting VKey Block VKey
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
. (VKey -> Const VKey VKey) -> BlockHeader -> Const VKey BlockHeader
Lens' BlockHeader VKey
Abstract.bhIssuer)
              BlockCount
stableAfter
              (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
State CHAIN
lastState
      ValidationMode
vMode <- Gen ValidationMode -> PropertyT IO ValidationMode
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen ValidationMode -> PropertyT IO ValidationMode)
-> Gen ValidationMode -> PropertyT IO ValidationMode
forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> ValidationMode
fromBlockValidationMode (BlockValidationMode -> ValidationMode)
-> GenT Identity BlockValidationMode -> Gen ValidationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity BlockValidationMode
genBlockValidationMode
      let (ABlock ByteString
concreteBlock, AbstractToConcreteIdMaps
_txIdMap') =
            AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (ABlock ByteString, AbstractToConcreteIdMaps)
elaborateBS
              AbstractToConcreteIdMaps
forall a. Monoid a => a
mempty {transactionIds = txIdMap}
              Config
config
              DCert
dCert
              ChainValidationState
cvs
              Block
abstractBlock
      ABlock ByteString -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow ABlock ByteString
concreteBlock
      Either ChainValidationError ChainValidationState
updateRes <-
        (ReaderT
  ValidationMode
  (PropertyT IO)
  (Either ChainValidationError ChainValidationState)
-> ValidationMode
-> PropertyT IO (Either ChainValidationError ChainValidationState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          (ReaderT
   ValidationMode
   (PropertyT IO)
   (Either ChainValidationError ChainValidationState)
 -> PropertyT IO (Either ChainValidationError ChainValidationState))
-> (ExceptT
      ChainValidationError
      (ReaderT ValidationMode (PropertyT IO))
      ChainValidationState
    -> ReaderT
         ValidationMode
         (PropertyT IO)
         (Either ChainValidationError ChainValidationState))
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
-> PropertyT IO (Either ChainValidationError 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
. ExceptT
  ChainValidationError
  (ReaderT ValidationMode (PropertyT IO))
  ChainValidationState
-> ReaderT
     ValidationMode
     (PropertyT IO)
     (Either ChainValidationError ChainValidationState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          (ExceptT
   ChainValidationError
   (ReaderT ValidationMode (PropertyT IO))
   ChainValidationState
 -> PropertyT IO (Either ChainValidationError ChainValidationState))
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
-> PropertyT IO (Either ChainValidationError ChainValidationState)
forall a b. (a -> b) -> a -> b
$ Config
-> ChainValidationState
-> ABlock ByteString
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
cvs ABlock ByteString
concreteBlock
      case Either ChainValidationError ChainValidationState
updateRes of
        Left ChainValidationError
_ -> PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right ChainValidationState
_ -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success

-- | Property: When calling 'updateBlock' given a 'Block' with an invalid
-- 'Proof', 'Block' validation should only pass in the 'NoBlockValidation' mode.
-- This is because this mode does not perform any validation on the 'Block'.
ts_prop_updateBlock_InvalidProof :: TSProperty
ts_prop_updateBlock_InvalidProof :: TSProperty
ts_prop_updateBlock_InvalidProof =
  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)
trace @CHAIN () Word64
traceLength
      let chainEnv :: Environment CHAIN
chainEnv@(Slot
_, UTxO
abstractInitialUTxO, Set VKeyGenesis
_, PParams
_, BlockCount
stableAfter) = Trace CHAIN -> Environment CHAIN
forall s. Trace s -> Environment s
Trace._traceEnv Trace CHAIN
sampleTrace
          lastState :: State CHAIN
lastState = Trace CHAIN -> State CHAIN
forall s. Trace s -> State s
Trace.lastState Trace CHAIN
sampleTrace
      Block
abstractBlock <-
        Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          (Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN))
-> Gen (Signal CHAIN) -> PropertyT IO (Signal CHAIN)
forall a b. (a -> b) -> a -> b
$ ShouldGenDelegation
-> ShouldGenUTxO
-> ShouldGenUpdate
-> Environment CHAIN
-> State CHAIN
-> Gen (Signal CHAIN)
Abstract.sigGenChain
            ShouldGenDelegation
Abstract.NoGenDelegation
            ShouldGenUTxO
Abstract.NoGenUTxO
            ShouldGenUpdate
Abstract.NoGenUpdate
            (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
Environment CHAIN
chainEnv
            (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
State CHAIN
lastState
      let config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
Environment CHAIN
chainEnv
          cvs :: ChainValidationState
cvs = (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
a -> ChainValidationState
a) (Config -> Either Error ChainValidationState
forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config)
          (UTxO
_, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractInitialUTxO
          dCert :: DCert
dCert = HasCallStack => VKey -> BlockCount -> State CHAIN -> DCert
VKey -> BlockCount -> State CHAIN -> DCert
rcDCert (Block
abstractBlock Block -> Getting VKey Block VKey -> VKey
forall s a. s -> Getting a s a -> a
^. (BlockHeader -> Const VKey BlockHeader)
-> Block -> Const VKey Block
Lens' Block BlockHeader
Abstract.bHeader ((BlockHeader -> Const VKey BlockHeader)
 -> Block -> Const VKey Block)
-> ((VKey -> Const VKey VKey)
    -> BlockHeader -> Const VKey BlockHeader)
-> Getting VKey Block VKey
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
. (VKey -> Const VKey VKey) -> BlockHeader -> Const VKey BlockHeader
Lens' BlockHeader VKey
Abstract.bhIssuer) BlockCount
stableAfter (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
State CHAIN
lastState
      ValidationMode
vMode <- Gen ValidationMode -> PropertyT IO ValidationMode
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen ValidationMode -> PropertyT IO ValidationMode)
-> Gen ValidationMode -> PropertyT IO ValidationMode
forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> ValidationMode
fromBlockValidationMode (BlockValidationMode -> ValidationMode)
-> GenT Identity BlockValidationMode -> Gen ValidationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity BlockValidationMode
genBlockValidationMode
      let (ABlock ByteString
concreteBlock, AbstractToConcreteIdMaps
_abstractToConcreteIdMaps') =
            AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (ABlock ByteString, AbstractToConcreteIdMaps)
elaborateBS
              AbstractToConcreteIdMaps
initialAbstractToConcreteIdMaps
              Config
config
              DCert
dCert
              ChainValidationState
cvs
              Block
abstractBlock
          initialAbstractToConcreteIdMaps :: AbstractToConcreteIdMaps
initialAbstractToConcreteIdMaps = AbstractToConcreteIdMaps
forall a. Monoid a => a
mempty {transactionIds = txIdMap}
      ABlock ByteString -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow ABlock ByteString
concreteBlock
      ABlock ByteString
invalidBlock <- Gen (ABlock ByteString) -> PropertyT IO (ABlock ByteString)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (ABlock ByteString) -> PropertyT IO (ABlock ByteString))
-> Gen (ABlock ByteString) -> PropertyT IO (ABlock ByteString)
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> Gen (ABlock ByteString)
invalidateABlockProof ABlock ByteString
concreteBlock
      Either ChainValidationError ChainValidationState
updateRes <-
        (ReaderT
  ValidationMode
  (PropertyT IO)
  (Either ChainValidationError ChainValidationState)
-> ValidationMode
-> PropertyT IO (Either ChainValidationError ChainValidationState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          (ReaderT
   ValidationMode
   (PropertyT IO)
   (Either ChainValidationError ChainValidationState)
 -> PropertyT IO (Either ChainValidationError ChainValidationState))
-> (ExceptT
      ChainValidationError
      (ReaderT ValidationMode (PropertyT IO))
      ChainValidationState
    -> ReaderT
         ValidationMode
         (PropertyT IO)
         (Either ChainValidationError ChainValidationState))
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
-> PropertyT IO (Either ChainValidationError 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
. ExceptT
  ChainValidationError
  (ReaderT ValidationMode (PropertyT IO))
  ChainValidationState
-> ReaderT
     ValidationMode
     (PropertyT IO)
     (Either ChainValidationError ChainValidationState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          (ExceptT
   ChainValidationError
   (ReaderT ValidationMode (PropertyT IO))
   ChainValidationState
 -> PropertyT IO (Either ChainValidationError ChainValidationState))
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
-> PropertyT IO (Either ChainValidationError ChainValidationState)
forall a b. (a -> b) -> a -> b
$ Config
-> ChainValidationState
-> ABlock ByteString
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode (PropertyT IO))
     ChainValidationState
forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
cvs ABlock ByteString
invalidBlock
      case Either ChainValidationError ChainValidationState
updateRes of
        Left ChainValidationError
_ ->
          if (ValidationMode -> BlockValidationMode
blockValidationMode ValidationMode
vMode) BlockValidationMode -> BlockValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== BlockValidationMode
BlockValidation
            then PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success
            else PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right ChainValidationState
_ ->
          if (ValidationMode -> BlockValidationMode
blockValidationMode ValidationMode
vMode) BlockValidationMode -> BlockValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== BlockValidationMode
NoBlockValidation
            then PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success
            else PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure

--------------------------------------------------------------------------------
-- Generators
--------------------------------------------------------------------------------

genHash :: Gen Abstract.Hash
genHash :: Gen Hash
genHash = Maybe Int -> Hash
Abstract.Hash (Maybe Int -> Hash) -> (Int -> Maybe Int) -> Int -> Hash
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
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Hash) -> GenT Identity Int -> Gen Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int Range Int
forall a. (Bounded a, Num a) => Range a
Range.constantBounded

genBlockValidationMode :: Gen BlockValidationMode
genBlockValidationMode :: GenT Identity BlockValidationMode
genBlockValidationMode = [BlockValidationMode] -> GenT Identity BlockValidationMode
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element [BlockValidationMode
BlockValidation, BlockValidationMode
NoBlockValidation]

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

createInitialUTxOState ::
  Environment UTXOWS ->
  State UTXOWS
createInitialUTxOState :: Environment UTXOWS -> State UTXOWS
createInitialUTxOState Environment UTXOWS
utxoEnv =
  UTxOState {utxo :: UTxO
utxo = UTxO
utxo0, reserves :: Lovelace
reserves = Lovelace
lovelaceCap Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- UTxO -> Lovelace
Abstract.balance UTxO
utxo0}
  where
    UTxOEnv
      { UTxO
utxo0 :: UTxO
utxo0 :: UTxOEnv -> UTxO
utxo0
      } = Environment UTXOWS
utxoEnv

createInitialDState ::
  Environment ADELEGS ->
  State ADELEGS
createInitialDState :: Environment ADELEGS -> State ADELEGS
createInitialDState Environment ADELEGS
env =
  DState
    { _dStateDelegationMap :: Bimap VKeyGenesis VKey
_dStateDelegationMap =
        [(VKeyGenesis, VKey)] -> Bimap VKeyGenesis VKey
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList
          ([(VKeyGenesis, VKey)] -> Bimap VKeyGenesis VKey)
-> [(VKeyGenesis, VKey)] -> Bimap VKeyGenesis VKey
forall a b. (a -> b) -> a -> b
$ (VKeyGenesis -> (VKeyGenesis, VKey))
-> [VKeyGenesis] -> [(VKeyGenesis, VKey)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
            (\vkg :: VKeyGenesis
vkg@(Abstract.VKeyGenesis VKey
key) -> (VKeyGenesis
vkg, VKey
key))
            (Set VKeyGenesis -> [VKeyGenesis]
forall a. Set a -> [a]
S.toList Set VKeyGenesis
Environment ADELEGS
env)
    , _dStateLastDelegation :: Map VKeyGenesis Slot
_dStateLastDelegation = (VKeyGenesis -> Slot) -> Set VKeyGenesis -> Map VKeyGenesis Slot
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Slot -> VKeyGenesis -> Slot
forall a b. a -> b -> a
const (Word64 -> Slot
Abstract.Slot Word64
0)) Set VKeyGenesis
Environment ADELEGS
env
    }

createInitialDIState ::
  State ADELEGS ->
  State DELEG
createInitialDIState :: State ADELEGS -> State DELEG
createInitialDIState State ADELEGS
dState =
  DIState
    { _dIStateDelegationMap :: Bimap VKeyGenesis VKey
_dIStateDelegationMap = DState -> Bimap VKeyGenesis VKey
_dStateDelegationMap DState
State ADELEGS
dState
    , _dIStateLastDelegation :: Map VKeyGenesis Slot
_dIStateLastDelegation = DState -> Map VKeyGenesis Slot
_dStateLastDelegation DState
State ADELEGS
dState
    , _dIStateScheduledDelegations :: [(Slot, (VKeyGenesis, VKey))]
_dIStateScheduledDelegations = []
    , _dIStateKeyEpochDelegations :: Set (Epoch, VKeyGenesis)
_dIStateKeyEpochDelegations = Set (Epoch, VKeyGenesis)
forall a. Set a
S.empty
    }

modifyAHeader ::
  (AHeader ByteString -> AHeader ByteString) ->
  ABlock ByteString ->
  ABlock ByteString
modifyAHeader :: (AHeader ByteString -> AHeader ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAHeader AHeader ByteString -> AHeader ByteString
ahModifier ABlock ByteString
ab =
  ABlock ByteString
ab {blockHeader = ahModifier (blockHeader ab)}

modifyAProof ::
  (Annotated Proof ByteString -> Annotated Proof ByteString) ->
  ABlock ByteString ->
  ABlock ByteString
modifyAProof :: (Annotated Proof ByteString -> Annotated Proof ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAProof Annotated Proof ByteString -> Annotated Proof ByteString
apModifier ABlock ByteString
ab =
  (AHeader ByteString -> AHeader ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAHeader AHeader ByteString -> AHeader ByteString
ahModifier ABlock ByteString
ab
  where
    ahModifier :: AHeader ByteString -> AHeader ByteString
    ahModifier :: AHeader ByteString -> AHeader ByteString
ahModifier AHeader ByteString
ah = AHeader ByteString
ah {aHeaderProof = apModifier (aHeaderProof ah)}

modifyDelegationProof ::
  (Hash Delegation.Payload -> Hash Delegation.Payload) ->
  ABlock ByteString ->
  ABlock ByteString
modifyDelegationProof :: (Hash Payload -> Hash Payload)
-> ABlock ByteString -> ABlock ByteString
modifyDelegationProof Hash Payload -> Hash Payload
dpModifier ABlock ByteString
ab =
  (Annotated Proof ByteString -> Annotated Proof ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAProof Annotated Proof ByteString -> Annotated Proof ByteString
apModifier ABlock ByteString
ab
  where
    apModifier :: Annotated Proof ByteString -> Annotated Proof ByteString
    apModifier :: Annotated Proof ByteString -> Annotated Proof ByteString
apModifier (Annotated Proof
p ByteString
bs) =
      Proof -> ByteString -> Annotated Proof ByteString
forall b a. b -> a -> Annotated b a
Annotated
        Proof
p {proofDelegation = dpModifier (proofDelegation p)}
        ByteString
bs

modifyTxProof ::
  (TxProof -> TxProof) ->
  ABlock ByteString ->
  ABlock ByteString
modifyTxProof :: (TxProof -> TxProof) -> ABlock ByteString -> ABlock ByteString
modifyTxProof TxProof -> TxProof
tpModifier ABlock ByteString
ab =
  (Annotated Proof ByteString -> Annotated Proof ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAProof Annotated Proof ByteString -> Annotated Proof ByteString
apModifier ABlock ByteString
ab
  where
    apModifier :: Annotated Proof ByteString -> Annotated Proof ByteString
    apModifier :: Annotated Proof ByteString -> Annotated Proof ByteString
apModifier (Annotated Proof
p ByteString
bs) =
      Proof -> ByteString -> Annotated Proof ByteString
forall b a. b -> a -> Annotated b a
Annotated
        Proof
p {proofUTxO = tpModifier (proofUTxO p)}
        ByteString
bs

invalidateABlockProof ::
  ABlock ByteString ->
  Gen (ABlock ByteString)
invalidateABlockProof :: ABlock ByteString -> Gen (ABlock ByteString)
invalidateABlockProof ABlock ByteString
ab =
  -- 'Gen.filter' to ensure we don't generate a valid proof
  (ABlock ByteString -> Bool)
-> Gen (ABlock ByteString) -> Gen (ABlock ByteString)
forall (m :: * -> *) a.
(MonadGen m, GenBase m ~ Identity) =>
(a -> Bool) -> m a -> m a
Gen.filter (\ABlock ByteString
x -> ABlock ByteString -> Proof
forall a. ABlock a -> Proof
blockProof ABlock ByteString
x Proof -> Proof -> Bool
forall a. Eq a => a -> a -> Bool
/= ABlock ByteString -> Proof
forall a. ABlock a -> Proof
blockProof ABlock ByteString
ab) (Gen (ABlock ByteString) -> Gen (ABlock ByteString))
-> Gen (ABlock ByteString) -> Gen (ABlock ByteString)
forall a b. (a -> b) -> a -> b
$ do
    TxProof
txProof <-
      [GenT Identity TxProof] -> GenT Identity TxProof
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ TxProof -> GenT Identity TxProof
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxProof -> GenT Identity TxProof)
-> TxProof -> GenT Identity TxProof
forall a b. (a -> b) -> a -> b
$ (Proof -> TxProof
proofUTxO (Proof -> TxProof)
-> (ABlock ByteString -> Proof) -> ABlock ByteString -> TxProof
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
. ABlock ByteString -> Proof
forall a. ABlock a -> Proof
blockProof) ABlock ByteString
ab
        , (ProtocolMagicId -> GenT Identity TxProof) -> GenT Identity TxProof
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> GenT Identity TxProof
genTxProof
        ]
    Hash Payload
dlgProof <-
      [GenT Identity (Hash Payload)] -> GenT Identity (Hash Payload)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ Hash Payload -> GenT Identity (Hash Payload)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash Payload -> GenT Identity (Hash Payload))
-> Hash Payload -> GenT Identity (Hash Payload)
forall a b. (a -> b) -> a -> b
$ (Proof -> Hash Payload
proofDelegation (Proof -> Hash Payload)
-> (ABlock ByteString -> Proof)
-> ABlock ByteString
-> Hash Payload
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
. ABlock ByteString -> Proof
forall a. ABlock a -> Proof
blockProof) ABlock ByteString
ab
        , Gen Payload -> GenT Identity (Hash Payload)
forall a algo.
(EncCBOR a, HashAlgorithm algo) =>
Gen a -> Gen (AbstractHash algo a)
genAbstractHash ((ProtocolMagicId -> Gen Payload) -> Gen Payload
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Payload
Delegation.genPayload)
        ]
    Proof
updProof <-
      [GenT Identity Proof] -> GenT Identity Proof
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ Proof -> GenT Identity Proof
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proof -> GenT Identity Proof) -> Proof -> GenT Identity Proof
forall a b. (a -> b) -> a -> b
$ Proof -> Proof
proofUpdate (ABlock ByteString -> Proof
forall a. ABlock a -> Proof
blockProof ABlock ByteString
ab)
        , (ProtocolMagicId -> GenT Identity Proof) -> GenT Identity Proof
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> GenT Identity Proof
Update.genProof
        ]
    ABlock ByteString -> Gen (ABlock ByteString)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (ABlock ByteString -> Gen (ABlock ByteString))
-> ABlock ByteString -> Gen (ABlock ByteString)
forall a b. (a -> b) -> a -> b
$ (Annotated Proof ByteString -> Annotated Proof ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAProof
        ( \(Annotated Proof
p ByteString
bs) ->
            Proof -> ByteString -> Annotated Proof ByteString
forall b a. b -> a -> Annotated b a
Annotated
              ( Proof
p
                  { proofUTxO = txProof
                  , proofDelegation = dlgProof
                  , proofUpdate = updProof
                  }
              )
              ByteString
bs
        )
        ABlock ByteString
ab

--------------------------------------------------------------------------------
-- Main Test Export
--------------------------------------------------------------------------------

tests :: TSGroup
tests :: TSGroup
tests = $$discoverPropArg