{-# 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
    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 -- 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 <- 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)
trace @CHAIN () Word64
traceLength
      let lastState :: State CHAIN
lastState = 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
                    ) = forall s. Trace s -> Environment s
Trace._traceEnv Trace CHAIN
sampleTrace
      Block
abstractBlock <-
        forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          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)
chainEnv
            (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
lastState
      let config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
chainEnv
          cvs :: ChainValidationState
cvs = 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) (\ChainValidationState
a -> ChainValidationState
a) (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
rcDCert
              (Block
abstractBlock forall s a. s -> Getting a s a -> a
^. Lens' Block BlockHeader
Abstract.bHeader forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockHeader VKey
Abstract.bhIssuer)
              BlockCount
stableAfter
              (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
lastState
      ValidationMode
vMode <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> ValidationMode
fromBlockValidationMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen BlockValidationMode
genBlockValidationMode
      let (ABlock ByteString
concreteBlock, AbstractToConcreteIdMaps
_txIdMap') =
            AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (ABlock ByteString, AbstractToConcreteIdMaps)
elaborateBS
              forall a. Monoid a => a
mempty {transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
txIdMap}
              Config
config
              DCert
dCert
              ChainValidationState
cvs
              Block
abstractBlock
      forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow ABlock ByteString
concreteBlock
      Either ChainValidationError ChainValidationState
updateRes <-
        (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          forall a b. (a -> b) -> a -> b
$ 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
_ -> forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right ChainValidationState
_ -> 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
    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)
trace @CHAIN () Word64
traceLength
      let chainEnv :: Environment CHAIN
chainEnv@(Slot
_, UTxO
abstractInitialUTxO, Set VKeyGenesis
_, PParams
_, BlockCount
stableAfter) = forall s. Trace s -> Environment s
Trace._traceEnv Trace CHAIN
sampleTrace
          lastState :: State CHAIN
lastState = forall s. Trace s -> State s
Trace.lastState Trace CHAIN
sampleTrace
      Block
abstractBlock <-
        forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          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)
chainEnv
            (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
lastState
      let config :: Config
config = Environment CHAIN -> Config
abEnvToCfg (Slot, UTxO, Set VKeyGenesis, PParams, BlockCount)
chainEnv
          cvs :: ChainValidationState
cvs = 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) (\ChainValidationState
a -> ChainValidationState
a) (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
rcDCert (Block
abstractBlock forall s a. s -> Getting a s a -> a
^. Lens' Block BlockHeader
Abstract.bHeader forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockHeader VKey
Abstract.bhIssuer) BlockCount
stableAfter (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
lastState
      ValidationMode
vMode <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> ValidationMode
fromBlockValidationMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen 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 = forall a. Monoid a => a
mempty {transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
txIdMap}
      forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow ABlock ByteString
concreteBlock
      ABlock ByteString
invalidBlock <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> Gen (ABlock ByteString)
invalidateABlockProof ABlock ByteString
concreteBlock
      Either ChainValidationError ChainValidationState
updateRes <-
        (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          forall a b. (a -> b) -> a -> b
$ 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) forall a. Eq a => a -> a -> Bool
== BlockValidationMode
BlockValidation
            then forall (m :: * -> *). MonadTest m => m ()
success
            else forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right ChainValidationState
_ ->
          if (ValidationMode -> BlockValidationMode
blockValidationMode ValidationMode
vMode) forall a. Eq a => a -> a -> Bool
== BlockValidationMode
NoBlockValidation
            then forall (m :: * -> *). MonadTest m => m ()
success
            else forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure

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

genHash :: Gen Abstract.Hash
genHash :: Gen Hash
genHash = Maybe Int -> Hash
Abstract.Hash forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int forall a. (Bounded a, Num a) => Range a
Range.constantBounded

genBlockValidationMode :: Gen BlockValidationMode
genBlockValidationMode :: Gen BlockValidationMode
genBlockValidationMode = 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 forall a. Num a => a -> a -> a
- UTxO -> Lovelace
Abstract.balance UTxO
utxo0}
  where
    UTxOEnv
      { UTxO
utxo0 :: UTxOEnv -> UTxO
utxo0 :: 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 =
        forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
            (\vkg :: VKeyGenesis
vkg@(Abstract.VKeyGenesis VKey
key) -> (VKeyGenesis
vkg, VKey
key))
            (forall a. Set a -> [a]
S.toList Environment ADELEGS
env)
    , _dStateLastDelegation :: Map VKeyGenesis Slot
_dStateLastDelegation = forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (forall a b. a -> b -> a
const (Word64 -> Slot
Abstract.Slot Word64
0)) 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 State ADELEGS
dState
    , _dIStateLastDelegation :: Map VKeyGenesis Slot
_dIStateLastDelegation = DState -> Map VKeyGenesis Slot
_dStateLastDelegation State ADELEGS
dState
    , _dIStateScheduledDelegations :: [(Slot, (VKeyGenesis, VKey))]
_dIStateScheduledDelegations = []
    , _dIStateKeyEpochDelegations :: Set (Epoch, VKeyGenesis)
_dIStateKeyEpochDelegations = 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 :: AHeader ByteString
blockHeader = AHeader ByteString -> AHeader ByteString
ahModifier (forall a. ABlock a -> AHeader a
blockHeader ABlock ByteString
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 :: Annotated Proof ByteString
aHeaderProof = Annotated Proof ByteString -> Annotated Proof ByteString
apModifier (forall a. AHeader a -> Annotated Proof a
aHeaderProof AHeader ByteString
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) =
      forall b a. b -> a -> Annotated b a
Annotated
        Proof
p {proofDelegation :: Hash Payload
proofDelegation = Hash Payload -> Hash Payload
dpModifier (Proof -> Hash Payload
proofDelegation Proof
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) =
      forall b a. b -> a -> Annotated b a
Annotated
        Proof
p {proofUTxO :: TxProof
proofUTxO = TxProof -> TxProof
tpModifier (Proof -> TxProof
proofUTxO Proof
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
  forall (m :: * -> *) a.
(MonadGen m, GenBase m ~ Identity) =>
(a -> Bool) -> m a -> m a
Gen.filter (\ABlock ByteString
x -> forall a. ABlock a -> Proof
blockProof ABlock ByteString
x forall a. Eq a => a -> a -> Bool
/= forall a. ABlock a -> Proof
blockProof ABlock ByteString
ab) forall a b. (a -> b) -> a -> b
$ do
    TxProof
txProof <-
      forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Proof -> TxProof
proofUTxO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. ABlock a -> Proof
blockProof) ABlock ByteString
ab
        , forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> GenT Identity TxProof
genTxProof
        ]
    Hash Payload
dlgProof <-
      forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Proof -> Hash Payload
proofDelegation forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. ABlock a -> Proof
blockProof) ABlock ByteString
ab
        , forall a algo.
(EncCBOR a, HashAlgorithm algo) =>
Gen a -> Gen (AbstractHash algo a)
genAbstractHash (forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Payload
Delegation.genPayload)
        ]
    Proof
updProof <-
      forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proof -> Proof
proofUpdate (forall a. ABlock a -> Proof
blockProof ABlock ByteString
ab)
        , forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> GenT Identity Proof
Update.genProof
        ]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall a b. (a -> b) -> a -> b
$ (Annotated Proof ByteString -> Annotated Proof ByteString)
-> ABlock ByteString -> ABlock ByteString
modifyAProof
        ( \(Annotated Proof
p ByteString
bs) ->
            forall b a. b -> a -> Annotated b a
Annotated
              ( Proof
p
                  { proofUTxO :: TxProof
proofUTxO = TxProof
txProof
                  , proofDelegation :: Hash Payload
proofDelegation = Hash Payload
dlgProof
                  , proofUpdate :: Proof
proofUpdate = Proof
updProof
                  }
              )
              ByteString
bs
        )
        ABlock ByteString
ab

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

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