{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Storage.TestBlock (
    -- * Test block
    BlockConfig (..)
  , ChainLength (..)
  , CodecConfig (..)
  , EBB (..)
  , Header (..)
  , StorageConfig (..)
  , TestBlock (..)
  , TestBody (..)
  , TestBodyHash (..)
  , TestHeader (..)
  , TestHeaderHash (..)
    -- ** Construction
  , firstBlock
  , firstEBB
  , mkBlock
  , mkNextBlock
  , mkNextBlock'
  , mkNextEBB
  , mkNextEBB'
    -- ** Query
  , testBlockChainLength
  , testBlockIsEBB
  , testBlockIsValid
    -- ** Serialisation
  , testBlockFromLazyByteString
  , testBlockToBuilder
  , testBlockToLazyByteString
    -- * Ledger
  , TestBlockError (..)
  , TestBlockOtherHeaderEnvelopeError (..)
  , mkTestConfig
  , testInitExtLedger
    -- * Corruptions
  , Corruptions
  , FileCorruption (..)
  , corruptFile
  , corruptionFiles
  , generateCorruptions
  , shrinkCorruptions
  ) where

import           Cardano.Crypto.DSIGN
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import           Codec.Serialise (Serialise (decode, encode), serialise)
import           Control.Monad (forM, when)
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Except (throwError)
import           Data.Binary (Binary)
import qualified Data.Binary as Binary
import           Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Functor (($>))
import           Data.Hashable
import           Data.Int (Int64)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import           Data.Maybe (maybeToList)
import           Data.TreeDiff
import           Data.Typeable (Typeable)
import           Data.Word
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.HardFork.History.EraParams
                     (EraParams (eraGenesisWin))
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.BFT
import           Ouroboros.Consensus.Protocol.ModChainSel
import           Ouroboros.Consensus.Protocol.Signed
import           Ouroboros.Consensus.Storage.ImmutableDB (Tip)
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Storage.VolatileDB
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()
import qualified Ouroboros.Network.Mock.Chain as Chain
import           System.FS.API.Lazy
import           Test.Cardano.Slotting.Numeric ()
import           Test.Cardano.Slotting.TreeDiff ()
import           Test.Ouroboros.Storage.ChainDB.Model
import           Test.QuickCheck
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Orphans.SignableRepresentation ()
import           Test.Util.Orphans.ToExpr ()

{-------------------------------------------------------------------------------
  TestBlock
-------------------------------------------------------------------------------}

data TestBlock = TestBlock {
      TestBlock -> TestHeader
testHeader :: !TestHeader
    , TestBlock -> TestBody
testBody   :: !TestBody
    }
  deriving stock    (Int -> TestBlock -> ShowS
[TestBlock] -> ShowS
TestBlock -> String
(Int -> TestBlock -> ShowS)
-> (TestBlock -> String)
-> ([TestBlock] -> ShowS)
-> Show TestBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlock -> ShowS
showsPrec :: Int -> TestBlock -> ShowS
$cshow :: TestBlock -> String
show :: TestBlock -> String
$cshowList :: [TestBlock] -> ShowS
showList :: [TestBlock] -> ShowS
Show, TestBlock -> TestBlock -> Bool
(TestBlock -> TestBlock -> Bool)
-> (TestBlock -> TestBlock -> Bool) -> Eq TestBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBlock -> TestBlock -> Bool
== :: TestBlock -> TestBlock -> Bool
$c/= :: TestBlock -> TestBlock -> Bool
/= :: TestBlock -> TestBlock -> Bool
Eq, (forall x. TestBlock -> Rep TestBlock x)
-> (forall x. Rep TestBlock x -> TestBlock) -> Generic TestBlock
forall x. Rep TestBlock x -> TestBlock
forall x. TestBlock -> Rep TestBlock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestBlock -> Rep TestBlock x
from :: forall x. TestBlock -> Rep TestBlock x
$cto :: forall x. Rep TestBlock x -> TestBlock
to :: forall x. Rep TestBlock x -> TestBlock
Generic, Typeable)
  deriving anyclass (Context -> TestBlock -> IO (Maybe ThunkInfo)
Proxy TestBlock -> String
(Context -> TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy TestBlock -> String)
-> NoThunks TestBlock
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBlock -> String
showTypeOf :: Proxy TestBlock -> String
NoThunks, [TestBlock] -> Encoding
TestBlock -> Encoding
(TestBlock -> Encoding)
-> (forall s. Decoder s TestBlock)
-> ([TestBlock] -> Encoding)
-> (forall s. Decoder s [TestBlock])
-> Serialise TestBlock
forall s. Decoder s [TestBlock]
forall s. Decoder s TestBlock
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestBlock -> Encoding
encode :: TestBlock -> Encoding
$cdecode :: forall s. Decoder s TestBlock
decode :: forall s. Decoder s TestBlock
$cencodeList :: [TestBlock] -> Encoding
encodeList :: [TestBlock] -> Encoding
$cdecodeList :: forall s. Decoder s [TestBlock]
decodeList :: forall s. Decoder s [TestBlock]
Serialise)

-- | Hash of a 'TestHeader'
newtype TestHeaderHash = TestHeaderHash Int
  deriving stock    (TestHeaderHash -> TestHeaderHash -> Bool
(TestHeaderHash -> TestHeaderHash -> Bool)
-> (TestHeaderHash -> TestHeaderHash -> Bool) -> Eq TestHeaderHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestHeaderHash -> TestHeaderHash -> Bool
== :: TestHeaderHash -> TestHeaderHash -> Bool
$c/= :: TestHeaderHash -> TestHeaderHash -> Bool
/= :: TestHeaderHash -> TestHeaderHash -> Bool
Eq, Eq TestHeaderHash
Eq TestHeaderHash =>
(TestHeaderHash -> TestHeaderHash -> Ordering)
-> (TestHeaderHash -> TestHeaderHash -> Bool)
-> (TestHeaderHash -> TestHeaderHash -> Bool)
-> (TestHeaderHash -> TestHeaderHash -> Bool)
-> (TestHeaderHash -> TestHeaderHash -> Bool)
-> (TestHeaderHash -> TestHeaderHash -> TestHeaderHash)
-> (TestHeaderHash -> TestHeaderHash -> TestHeaderHash)
-> Ord TestHeaderHash
TestHeaderHash -> TestHeaderHash -> Bool
TestHeaderHash -> TestHeaderHash -> Ordering
TestHeaderHash -> TestHeaderHash -> TestHeaderHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestHeaderHash -> TestHeaderHash -> Ordering
compare :: TestHeaderHash -> TestHeaderHash -> Ordering
$c< :: TestHeaderHash -> TestHeaderHash -> Bool
< :: TestHeaderHash -> TestHeaderHash -> Bool
$c<= :: TestHeaderHash -> TestHeaderHash -> Bool
<= :: TestHeaderHash -> TestHeaderHash -> Bool
$c> :: TestHeaderHash -> TestHeaderHash -> Bool
> :: TestHeaderHash -> TestHeaderHash -> Bool
$c>= :: TestHeaderHash -> TestHeaderHash -> Bool
>= :: TestHeaderHash -> TestHeaderHash -> Bool
$cmax :: TestHeaderHash -> TestHeaderHash -> TestHeaderHash
max :: TestHeaderHash -> TestHeaderHash -> TestHeaderHash
$cmin :: TestHeaderHash -> TestHeaderHash -> TestHeaderHash
min :: TestHeaderHash -> TestHeaderHash -> TestHeaderHash
Ord, Int -> TestHeaderHash -> ShowS
[TestHeaderHash] -> ShowS
TestHeaderHash -> String
(Int -> TestHeaderHash -> ShowS)
-> (TestHeaderHash -> String)
-> ([TestHeaderHash] -> ShowS)
-> Show TestHeaderHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestHeaderHash -> ShowS
showsPrec :: Int -> TestHeaderHash -> ShowS
$cshow :: TestHeaderHash -> String
show :: TestHeaderHash -> String
$cshowList :: [TestHeaderHash] -> ShowS
showList :: [TestHeaderHash] -> ShowS
Show, (forall x. TestHeaderHash -> Rep TestHeaderHash x)
-> (forall x. Rep TestHeaderHash x -> TestHeaderHash)
-> Generic TestHeaderHash
forall x. Rep TestHeaderHash x -> TestHeaderHash
forall x. TestHeaderHash -> Rep TestHeaderHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestHeaderHash -> Rep TestHeaderHash x
from :: forall x. TestHeaderHash -> Rep TestHeaderHash x
$cto :: forall x. Rep TestHeaderHash x -> TestHeaderHash
to :: forall x. Rep TestHeaderHash x -> TestHeaderHash
Generic)
  deriving newtype  (TestHeaderHash -> String
(TestHeaderHash -> String) -> Condense TestHeaderHash
forall a. (a -> String) -> Condense a
$ccondense :: TestHeaderHash -> String
condense :: TestHeaderHash -> String
Condense, Context -> TestHeaderHash -> IO (Maybe ThunkInfo)
Proxy TestHeaderHash -> String
(Context -> TestHeaderHash -> IO (Maybe ThunkInfo))
-> (Context -> TestHeaderHash -> IO (Maybe ThunkInfo))
-> (Proxy TestHeaderHash -> String)
-> NoThunks TestHeaderHash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestHeaderHash -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestHeaderHash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestHeaderHash -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestHeaderHash -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestHeaderHash -> String
showTypeOf :: Proxy TestHeaderHash -> String
NoThunks, Eq TestHeaderHash
Eq TestHeaderHash =>
(Int -> TestHeaderHash -> Int)
-> (TestHeaderHash -> Int) -> Hashable TestHeaderHash
Int -> TestHeaderHash -> Int
TestHeaderHash -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> TestHeaderHash -> Int
hashWithSalt :: Int -> TestHeaderHash -> Int
$chash :: TestHeaderHash -> Int
hash :: TestHeaderHash -> Int
Hashable, [TestHeaderHash] -> Encoding
TestHeaderHash -> Encoding
(TestHeaderHash -> Encoding)
-> (forall s. Decoder s TestHeaderHash)
-> ([TestHeaderHash] -> Encoding)
-> (forall s. Decoder s [TestHeaderHash])
-> Serialise TestHeaderHash
forall s. Decoder s [TestHeaderHash]
forall s. Decoder s TestHeaderHash
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestHeaderHash -> Encoding
encode :: TestHeaderHash -> Encoding
$cdecode :: forall s. Decoder s TestHeaderHash
decode :: forall s. Decoder s TestHeaderHash
$cencodeList :: [TestHeaderHash] -> Encoding
encodeList :: [TestHeaderHash] -> Encoding
$cdecodeList :: forall s. Decoder s [TestHeaderHash]
decodeList :: forall s. Decoder s [TestHeaderHash]
Serialise, Get TestHeaderHash
[TestHeaderHash] -> Put
TestHeaderHash -> Put
(TestHeaderHash -> Put)
-> Get TestHeaderHash
-> ([TestHeaderHash] -> Put)
-> Binary TestHeaderHash
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: TestHeaderHash -> Put
put :: TestHeaderHash -> Put
$cget :: Get TestHeaderHash
get :: Get TestHeaderHash
$cputList :: [TestHeaderHash] -> Put
putList :: [TestHeaderHash] -> Put
Binary)

-- | Hash of a 'TestBody'
newtype TestBodyHash = TestBodyHash Int
  deriving stock    (TestBodyHash -> TestBodyHash -> Bool
(TestBodyHash -> TestBodyHash -> Bool)
-> (TestBodyHash -> TestBodyHash -> Bool) -> Eq TestBodyHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBodyHash -> TestBodyHash -> Bool
== :: TestBodyHash -> TestBodyHash -> Bool
$c/= :: TestBodyHash -> TestBodyHash -> Bool
/= :: TestBodyHash -> TestBodyHash -> Bool
Eq, Eq TestBodyHash
Eq TestBodyHash =>
(TestBodyHash -> TestBodyHash -> Ordering)
-> (TestBodyHash -> TestBodyHash -> Bool)
-> (TestBodyHash -> TestBodyHash -> Bool)
-> (TestBodyHash -> TestBodyHash -> Bool)
-> (TestBodyHash -> TestBodyHash -> Bool)
-> (TestBodyHash -> TestBodyHash -> TestBodyHash)
-> (TestBodyHash -> TestBodyHash -> TestBodyHash)
-> Ord TestBodyHash
TestBodyHash -> TestBodyHash -> Bool
TestBodyHash -> TestBodyHash -> Ordering
TestBodyHash -> TestBodyHash -> TestBodyHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestBodyHash -> TestBodyHash -> Ordering
compare :: TestBodyHash -> TestBodyHash -> Ordering
$c< :: TestBodyHash -> TestBodyHash -> Bool
< :: TestBodyHash -> TestBodyHash -> Bool
$c<= :: TestBodyHash -> TestBodyHash -> Bool
<= :: TestBodyHash -> TestBodyHash -> Bool
$c> :: TestBodyHash -> TestBodyHash -> Bool
> :: TestBodyHash -> TestBodyHash -> Bool
$c>= :: TestBodyHash -> TestBodyHash -> Bool
>= :: TestBodyHash -> TestBodyHash -> Bool
$cmax :: TestBodyHash -> TestBodyHash -> TestBodyHash
max :: TestBodyHash -> TestBodyHash -> TestBodyHash
$cmin :: TestBodyHash -> TestBodyHash -> TestBodyHash
min :: TestBodyHash -> TestBodyHash -> TestBodyHash
Ord, Int -> TestBodyHash -> ShowS
[TestBodyHash] -> ShowS
TestBodyHash -> String
(Int -> TestBodyHash -> ShowS)
-> (TestBodyHash -> String)
-> ([TestBodyHash] -> ShowS)
-> Show TestBodyHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBodyHash -> ShowS
showsPrec :: Int -> TestBodyHash -> ShowS
$cshow :: TestBodyHash -> String
show :: TestBodyHash -> String
$cshowList :: [TestBodyHash] -> ShowS
showList :: [TestBodyHash] -> ShowS
Show, (forall x. TestBodyHash -> Rep TestBodyHash x)
-> (forall x. Rep TestBodyHash x -> TestBodyHash)
-> Generic TestBodyHash
forall x. Rep TestBodyHash x -> TestBodyHash
forall x. TestBodyHash -> Rep TestBodyHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestBodyHash -> Rep TestBodyHash x
from :: forall x. TestBodyHash -> Rep TestBodyHash x
$cto :: forall x. Rep TestBodyHash x -> TestBodyHash
to :: forall x. Rep TestBodyHash x -> TestBodyHash
Generic)
  deriving newtype  (TestBodyHash -> String
(TestBodyHash -> String) -> Condense TestBodyHash
forall a. (a -> String) -> Condense a
$ccondense :: TestBodyHash -> String
condense :: TestBodyHash -> String
Condense, Context -> TestBodyHash -> IO (Maybe ThunkInfo)
Proxy TestBodyHash -> String
(Context -> TestBodyHash -> IO (Maybe ThunkInfo))
-> (Context -> TestBodyHash -> IO (Maybe ThunkInfo))
-> (Proxy TestBodyHash -> String)
-> NoThunks TestBodyHash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestBodyHash -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBodyHash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestBodyHash -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBodyHash -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBodyHash -> String
showTypeOf :: Proxy TestBodyHash -> String
NoThunks, Eq TestBodyHash
Eq TestBodyHash =>
(Int -> TestBodyHash -> Int)
-> (TestBodyHash -> Int) -> Hashable TestBodyHash
Int -> TestBodyHash -> Int
TestBodyHash -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> TestBodyHash -> Int
hashWithSalt :: Int -> TestBodyHash -> Int
$chash :: TestBodyHash -> Int
hash :: TestBodyHash -> Int
Hashable, [TestBodyHash] -> Encoding
TestBodyHash -> Encoding
(TestBodyHash -> Encoding)
-> (forall s. Decoder s TestBodyHash)
-> ([TestBodyHash] -> Encoding)
-> (forall s. Decoder s [TestBodyHash])
-> Serialise TestBodyHash
forall s. Decoder s [TestBodyHash]
forall s. Decoder s TestBodyHash
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestBodyHash -> Encoding
encode :: TestBodyHash -> Encoding
$cdecode :: forall s. Decoder s TestBodyHash
decode :: forall s. Decoder s TestBodyHash
$cencodeList :: [TestBodyHash] -> Encoding
encodeList :: [TestBodyHash] -> Encoding
$cdecodeList :: forall s. Decoder s [TestBodyHash]
decodeList :: forall s. Decoder s [TestBodyHash]
Serialise)

data TestHeader = TestHeader {
      TestHeader -> HeaderHash TestHeader
thHash        :: HeaderHash TestHeader
      -- ^ Not included in the calculation of the hash of the 'TestHeader',
      -- i.e., in its own value, which would be pretty hard to do.
      --
      -- Note the absence of a bang: this field caches the 'TestHeader's hash.
      -- To calculate it, the 'TestHeader' is passed to the hashing function,
      -- even though the field is not read, making the field strict would
      -- create an infinite loop.
    , TestHeader -> ChainHash TestHeader
thPrevHash    :: !(ChainHash TestHeader)
    , TestHeader -> TestBodyHash
thBodyHash    :: !TestBodyHash
    , TestHeader -> SlotNo
thSlotNo      :: !SlotNo
    , TestHeader -> BlockNo
thBlockNo     :: !BlockNo
    , TestHeader -> ChainLength
thChainLength :: !ChainLength
    , TestHeader -> EBB
thIsEBB       :: !EBB
    }
  deriving stock    (TestHeader -> TestHeader -> Bool
(TestHeader -> TestHeader -> Bool)
-> (TestHeader -> TestHeader -> Bool) -> Eq TestHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestHeader -> TestHeader -> Bool
== :: TestHeader -> TestHeader -> Bool
$c/= :: TestHeader -> TestHeader -> Bool
/= :: TestHeader -> TestHeader -> Bool
Eq, Int -> TestHeader -> ShowS
[TestHeader] -> ShowS
TestHeader -> String
(Int -> TestHeader -> ShowS)
-> (TestHeader -> String)
-> ([TestHeader] -> ShowS)
-> Show TestHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestHeader -> ShowS
showsPrec :: Int -> TestHeader -> ShowS
$cshow :: TestHeader -> String
show :: TestHeader -> String
$cshowList :: [TestHeader] -> ShowS
showList :: [TestHeader] -> ShowS
Show, (forall x. TestHeader -> Rep TestHeader x)
-> (forall x. Rep TestHeader x -> TestHeader) -> Generic TestHeader
forall x. Rep TestHeader x -> TestHeader
forall x. TestHeader -> Rep TestHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestHeader -> Rep TestHeader x
from :: forall x. TestHeader -> Rep TestHeader x
$cto :: forall x. Rep TestHeader x -> TestHeader
to :: forall x. Rep TestHeader x -> TestHeader
Generic)
  deriving anyclass (Context -> TestHeader -> IO (Maybe ThunkInfo)
Proxy TestHeader -> String
(Context -> TestHeader -> IO (Maybe ThunkInfo))
-> (Context -> TestHeader -> IO (Maybe ThunkInfo))
-> (Proxy TestHeader -> String)
-> NoThunks TestHeader
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestHeader -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestHeader -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestHeader -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestHeader -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestHeader -> String
showTypeOf :: Proxy TestHeader -> String
NoThunks, [TestHeader] -> Encoding
TestHeader -> Encoding
(TestHeader -> Encoding)
-> (forall s. Decoder s TestHeader)
-> ([TestHeader] -> Encoding)
-> (forall s. Decoder s [TestHeader])
-> Serialise TestHeader
forall s. Decoder s [TestHeader]
forall s. Decoder s TestHeader
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestHeader -> Encoding
encode :: TestHeader -> Encoding
$cdecode :: forall s. Decoder s TestHeader
decode :: forall s. Decoder s TestHeader
$cencodeList :: [TestHeader] -> Encoding
encodeList :: [TestHeader] -> Encoding
$cdecodeList :: forall s. Decoder s [TestHeader]
decodeList :: forall s. Decoder s [TestHeader]
Serialise)

-- | Strict variant of @Maybe EpochNo@
data EBB =
    EBB !EpochNo
  | RegularBlock
  deriving stock    (EBB -> EBB -> Bool
(EBB -> EBB -> Bool) -> (EBB -> EBB -> Bool) -> Eq EBB
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EBB -> EBB -> Bool
== :: EBB -> EBB -> Bool
$c/= :: EBB -> EBB -> Bool
/= :: EBB -> EBB -> Bool
Eq, Int -> EBB -> ShowS
[EBB] -> ShowS
EBB -> String
(Int -> EBB -> ShowS)
-> (EBB -> String) -> ([EBB] -> ShowS) -> Show EBB
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EBB -> ShowS
showsPrec :: Int -> EBB -> ShowS
$cshow :: EBB -> String
show :: EBB -> String
$cshowList :: [EBB] -> ShowS
showList :: [EBB] -> ShowS
Show, (forall x. EBB -> Rep EBB x)
-> (forall x. Rep EBB x -> EBB) -> Generic EBB
forall x. Rep EBB x -> EBB
forall x. EBB -> Rep EBB x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EBB -> Rep EBB x
from :: forall x. EBB -> Rep EBB x
$cto :: forall x. Rep EBB x -> EBB
to :: forall x. Rep EBB x -> EBB
Generic)
  deriving anyclass (Context -> EBB -> IO (Maybe ThunkInfo)
Proxy EBB -> String
(Context -> EBB -> IO (Maybe ThunkInfo))
-> (Context -> EBB -> IO (Maybe ThunkInfo))
-> (Proxy EBB -> String)
-> NoThunks EBB
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> EBB -> IO (Maybe ThunkInfo)
noThunks :: Context -> EBB -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> EBB -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> EBB -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy EBB -> String
showTypeOf :: Proxy EBB -> String
NoThunks, [EBB] -> Encoding
EBB -> Encoding
(EBB -> Encoding)
-> (forall s. Decoder s EBB)
-> ([EBB] -> Encoding)
-> (forall s. Decoder s [EBB])
-> Serialise EBB
forall s. Decoder s [EBB]
forall s. Decoder s EBB
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: EBB -> Encoding
encode :: EBB -> Encoding
$cdecode :: forall s. Decoder s EBB
decode :: forall s. Decoder s EBB
$cencodeList :: [EBB] -> Encoding
encodeList :: [EBB] -> Encoding
$cdecodeList :: forall s. Decoder s [EBB]
decodeList :: forall s. Decoder s [EBB]
Serialise)

instance Hashable EBB where
  hashWithSalt :: Int -> EBB -> Int
hashWithSalt Int
s (EBB EpochNo
epoch)  = Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (EpochNo -> Word64
unEpochNo EpochNo
epoch)
  hashWithSalt Int
s EBB
RegularBlock = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (-Int
1 :: Int)

data TestBody = TestBody {
      TestBody -> Word
tbForkNo  :: !Word
      -- ^ If we don't have something that can vary per block, we're not
      -- generating forks, except when skipping slots. For example, when we
      -- want to have multiple different valid successor blocks created in the
      -- same slot, all fields in the header and body will be the same.
      -- Consequently, the hashes will also be the same, so we don't have
      -- different blocks after all. By using a different 'tbForkNo' for each
      -- block, we have different bodies, and thus different hashes.
      --
      -- Note that this is a /local/ number, it is specific to this block,
      -- other blocks need not be aware of it.
    , TestBody -> Bool
tbIsValid :: !Bool
    }
  deriving stock    (TestBody -> TestBody -> Bool
(TestBody -> TestBody -> Bool)
-> (TestBody -> TestBody -> Bool) -> Eq TestBody
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBody -> TestBody -> Bool
== :: TestBody -> TestBody -> Bool
$c/= :: TestBody -> TestBody -> Bool
/= :: TestBody -> TestBody -> Bool
Eq, Int -> TestBody -> ShowS
[TestBody] -> ShowS
TestBody -> String
(Int -> TestBody -> ShowS)
-> (TestBody -> String) -> ([TestBody] -> ShowS) -> Show TestBody
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBody -> ShowS
showsPrec :: Int -> TestBody -> ShowS
$cshow :: TestBody -> String
show :: TestBody -> String
$cshowList :: [TestBody] -> ShowS
showList :: [TestBody] -> ShowS
Show, (forall x. TestBody -> Rep TestBody x)
-> (forall x. Rep TestBody x -> TestBody) -> Generic TestBody
forall x. Rep TestBody x -> TestBody
forall x. TestBody -> Rep TestBody x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestBody -> Rep TestBody x
from :: forall x. TestBody -> Rep TestBody x
$cto :: forall x. Rep TestBody x -> TestBody
to :: forall x. Rep TestBody x -> TestBody
Generic)
  deriving anyclass (Context -> TestBody -> IO (Maybe ThunkInfo)
Proxy TestBody -> String
(Context -> TestBody -> IO (Maybe ThunkInfo))
-> (Context -> TestBody -> IO (Maybe ThunkInfo))
-> (Proxy TestBody -> String)
-> NoThunks TestBody
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestBody -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBody -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestBody -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBody -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBody -> String
showTypeOf :: Proxy TestBody -> String
NoThunks, [TestBody] -> Encoding
TestBody -> Encoding
(TestBody -> Encoding)
-> (forall s. Decoder s TestBody)
-> ([TestBody] -> Encoding)
-> (forall s. Decoder s [TestBody])
-> Serialise TestBody
forall s. Decoder s [TestBody]
forall s. Decoder s TestBody
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TestBody -> Encoding
encode :: TestBody -> Encoding
$cdecode :: forall s. Decoder s TestBody
decode :: forall s. Decoder s TestBody
$cencodeList :: [TestBody] -> Encoding
encodeList :: [TestBody] -> Encoding
$cdecodeList :: forall s. Decoder s [TestBody]
decodeList :: forall s. Decoder s [TestBody]
Serialise, Eq TestBody
Eq TestBody =>
(Int -> TestBody -> Int) -> (TestBody -> Int) -> Hashable TestBody
Int -> TestBody -> Int
TestBody -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> TestBody -> Int
hashWithSalt :: Int -> TestBody -> Int
$chash :: TestBody -> Int
hash :: TestBody -> Int
Hashable)

newtype instance Header TestBlock = TestHeader' { Header TestBlock -> TestHeader
unTestHeader :: TestHeader }
  deriving newtype (Header TestBlock -> Header TestBlock -> Bool
(Header TestBlock -> Header TestBlock -> Bool)
-> (Header TestBlock -> Header TestBlock -> Bool)
-> Eq (Header TestBlock)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header TestBlock -> Header TestBlock -> Bool
== :: Header TestBlock -> Header TestBlock -> Bool
$c/= :: Header TestBlock -> Header TestBlock -> Bool
/= :: Header TestBlock -> Header TestBlock -> Bool
Eq, Int -> Header TestBlock -> ShowS
[Header TestBlock] -> ShowS
Header TestBlock -> String
(Int -> Header TestBlock -> ShowS)
-> (Header TestBlock -> String)
-> ([Header TestBlock] -> ShowS)
-> Show (Header TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header TestBlock -> ShowS
showsPrec :: Int -> Header TestBlock -> ShowS
$cshow :: Header TestBlock -> String
show :: Header TestBlock -> String
$cshowList :: [Header TestBlock] -> ShowS
showList :: [Header TestBlock] -> ShowS
Show, Context -> Header TestBlock -> IO (Maybe ThunkInfo)
Proxy (Header TestBlock) -> String
(Context -> Header TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> Header TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (Header TestBlock) -> String)
-> NoThunks (Header TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Header TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> Header TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Header TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Header TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Header TestBlock) -> String
showTypeOf :: Proxy (Header TestBlock) -> String
NoThunks, [Header TestBlock] -> Encoding
Header TestBlock -> Encoding
(Header TestBlock -> Encoding)
-> (forall s. Decoder s (Header TestBlock))
-> ([Header TestBlock] -> Encoding)
-> (forall s. Decoder s [Header TestBlock])
-> Serialise (Header TestBlock)
forall s. Decoder s [Header TestBlock]
forall s. Decoder s (Header TestBlock)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Header TestBlock -> Encoding
encode :: Header TestBlock -> Encoding
$cdecode :: forall s. Decoder s (Header TestBlock)
decode :: forall s. Decoder s (Header TestBlock)
$cencodeList :: [Header TestBlock] -> Encoding
encodeList :: [Header TestBlock] -> Encoding
$cdecodeList :: forall s. Decoder s [Header TestBlock]
decodeList :: forall s. Decoder s [Header TestBlock]
Serialise)

instance GetHeader TestBlock where
  getHeader :: TestBlock -> Header TestBlock
getHeader = TestHeader -> Header TestBlock
TestHeader' (TestHeader -> Header TestBlock)
-> (TestBlock -> TestHeader) -> TestBlock -> Header TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> TestHeader
testHeader

  blockMatchesHeader :: Header TestBlock -> TestBlock -> Bool
blockMatchesHeader (TestHeader' TestHeader
hdr) TestBlock
blk =
      TestHeader -> TestBodyHash
thBodyHash TestHeader
hdr TestBodyHash -> TestBodyHash -> Bool
forall a. Eq a => a -> a -> Bool
== TestBody -> TestBodyHash
hashBody (TestBlock -> TestBody
testBody TestBlock
blk)

  headerIsEBB :: Header TestBlock -> Maybe EpochNo
headerIsEBB (TestHeader' TestHeader
hdr) = case TestHeader -> EBB
thIsEBB TestHeader
hdr of
    EBB EpochNo
epochNo  -> EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epochNo
    EBB
RegularBlock -> Maybe EpochNo
forall a. Maybe a
Nothing

instance StandardHash TestBlock
instance StandardHash TestHeader

type instance HeaderHash TestBlock = TestHeaderHash
type instance HeaderHash TestHeader = TestHeaderHash

instance ConvertRawHash TestBlock where
  toRawHash :: forall (proxy :: * -> *).
proxy TestBlock -> HeaderHash TestBlock -> ByteString
toRawHash   proxy TestBlock
_ = ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString)
-> (TestHeaderHash -> ByteString) -> TestHeaderHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHeaderHash -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode
  fromRawHash :: forall (proxy :: * -> *).
proxy TestBlock -> ByteString -> HeaderHash TestBlock
fromRawHash proxy TestBlock
_ = ByteString -> TestHeaderHash
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> TestHeaderHash)
-> (ByteString -> ByteString) -> ByteString -> TestHeaderHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.fromStrict
  hashSize :: forall (proxy :: * -> *). proxy TestBlock -> Word32
hashSize    proxy TestBlock
_ = Word32
8

instance HasHeader TestBlock where
  getHeaderFields :: TestBlock -> HeaderFields TestBlock
getHeaderFields = TestBlock -> HeaderFields TestBlock
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields

instance HasHeader (Header TestBlock) where
  getHeaderFields :: Header TestBlock -> HeaderFields (Header TestBlock)
getHeaderFields (TestHeader' TestHeader{BlockNo
SlotNo
ChainHash TestHeader
HeaderHash TestHeader
ChainLength
EBB
TestBodyHash
thHash :: TestHeader -> HeaderHash TestHeader
thPrevHash :: TestHeader -> ChainHash TestHeader
thBodyHash :: TestHeader -> TestBodyHash
thSlotNo :: TestHeader -> SlotNo
thBlockNo :: TestHeader -> BlockNo
thChainLength :: TestHeader -> ChainLength
thIsEBB :: TestHeader -> EBB
thHash :: HeaderHash TestHeader
thPrevHash :: ChainHash TestHeader
thBodyHash :: TestBodyHash
thSlotNo :: SlotNo
thBlockNo :: BlockNo
thChainLength :: ChainLength
thIsEBB :: EBB
..}) = HeaderFields {
        headerFieldHash :: HeaderHash (Header TestBlock)
headerFieldHash    = HeaderHash (Header TestBlock)
HeaderHash TestHeader
thHash
      , headerFieldSlot :: SlotNo
headerFieldSlot    = SlotNo
thSlotNo
      , headerFieldBlockNo :: BlockNo
headerFieldBlockNo = BlockNo
thBlockNo
      }

instance GetPrevHash TestBlock where
  headerPrevHash :: Header TestBlock -> ChainHash TestBlock
headerPrevHash = ChainHash TestHeader -> ChainHash TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash TestHeader -> ChainHash TestBlock)
-> (Header TestBlock -> ChainHash TestHeader)
-> Header TestBlock
-> ChainHash TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHeader -> ChainHash TestHeader
thPrevHash (TestHeader -> ChainHash TestHeader)
-> (Header TestBlock -> TestHeader)
-> Header TestBlock
-> ChainHash TestHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header TestBlock -> TestHeader
unTestHeader

data instance BlockConfig TestBlock = TestBlockConfig {
      -- | Whether the test block can be EBBs or not. This can vary per test
      -- case. It will be used by 'validateEnvelope' to forbid EBBs 'False'.
      BlockConfig TestBlock -> Bool
testBlockEBBsAllowed  :: !Bool

      -- | Number of core nodes
      --
      -- We need this in order to compute the 'ValidateView', which must
      -- conjure up a validation key out of thin air
    , BlockConfig TestBlock -> NumCoreNodes
testBlockNumCoreNodes :: !NumCoreNodes
    }
  deriving ((forall x. BlockConfig TestBlock -> Rep (BlockConfig TestBlock) x)
-> (forall x.
    Rep (BlockConfig TestBlock) x -> BlockConfig TestBlock)
-> Generic (BlockConfig TestBlock)
forall x. Rep (BlockConfig TestBlock) x -> BlockConfig TestBlock
forall x. BlockConfig TestBlock -> Rep (BlockConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BlockConfig TestBlock -> Rep (BlockConfig TestBlock) x
from :: forall x. BlockConfig TestBlock -> Rep (BlockConfig TestBlock) x
$cto :: forall x. Rep (BlockConfig TestBlock) x -> BlockConfig TestBlock
to :: forall x. Rep (BlockConfig TestBlock) x -> BlockConfig TestBlock
Generic, Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (BlockConfig TestBlock) -> String
(Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (BlockConfig TestBlock) -> String)
-> NoThunks (BlockConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (BlockConfig TestBlock) -> String
showTypeOf :: Proxy (BlockConfig TestBlock) -> String
NoThunks)

data instance CodecConfig TestBlock = TestBlockCodecConfig
  deriving ((forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x)
-> (forall x.
    Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock)
-> Generic (CodecConfig TestBlock)
forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
from :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
$cto :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
to :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
Generic, Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (CodecConfig TestBlock) -> String
(Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig TestBlock) -> String)
-> NoThunks (CodecConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (CodecConfig TestBlock) -> String
showTypeOf :: Proxy (CodecConfig TestBlock) -> String
NoThunks, Int -> CodecConfig TestBlock -> ShowS
[CodecConfig TestBlock] -> ShowS
CodecConfig TestBlock -> String
(Int -> CodecConfig TestBlock -> ShowS)
-> (CodecConfig TestBlock -> String)
-> ([CodecConfig TestBlock] -> ShowS)
-> Show (CodecConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodecConfig TestBlock -> ShowS
showsPrec :: Int -> CodecConfig TestBlock -> ShowS
$cshow :: CodecConfig TestBlock -> String
show :: CodecConfig TestBlock -> String
$cshowList :: [CodecConfig TestBlock] -> ShowS
showList :: [CodecConfig TestBlock] -> ShowS
Show)

data instance StorageConfig TestBlock = TestBlockStorageConfig
  deriving ((forall x.
 StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x)
-> (forall x.
    Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock)
-> Generic (StorageConfig TestBlock)
forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
from :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
$cto :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
to :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
Generic, Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (StorageConfig TestBlock) -> String
(Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig TestBlock) -> String)
-> NoThunks (StorageConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (StorageConfig TestBlock) -> String
showTypeOf :: Proxy (StorageConfig TestBlock) -> String
NoThunks, Int -> StorageConfig TestBlock -> ShowS
[StorageConfig TestBlock] -> ShowS
StorageConfig TestBlock -> String
(Int -> StorageConfig TestBlock -> ShowS)
-> (StorageConfig TestBlock -> String)
-> ([StorageConfig TestBlock] -> ShowS)
-> Show (StorageConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StorageConfig TestBlock -> ShowS
showsPrec :: Int -> StorageConfig TestBlock -> ShowS
$cshow :: StorageConfig TestBlock -> String
show :: StorageConfig TestBlock -> String
$cshowList :: [StorageConfig TestBlock] -> ShowS
showList :: [StorageConfig TestBlock] -> ShowS
Show)

instance Condense TestBlock where
  condense :: TestBlock -> String
condense = TestBlock -> String
forall a. Show a => a -> String
show -- TODO

instance Condense TestHeader where
  condense :: TestHeader -> String
condense = TestHeader -> String
forall a. Show a => a -> String
show -- TODO

hashBody :: TestBody -> TestBodyHash
hashBody :: TestBody -> TestBodyHash
hashBody = Int -> TestBodyHash
TestBodyHash (Int -> TestBodyHash)
-> (TestBody -> Int) -> TestBody -> TestBodyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBody -> Int
forall a. Hashable a => a -> Int
hash

hashHeader :: TestHeader -> TestHeaderHash
hashHeader :: TestHeader -> TestHeaderHash
hashHeader (TestHeader HeaderHash TestHeader
_ ChainHash TestHeader
a TestBodyHash
b SlotNo
c BlockNo
d ChainLength
e EBB
f) = Int -> TestHeaderHash
TestHeaderHash ((ChainHash TestHeader, TestBodyHash, SlotNo, BlockNo, ChainLength,
 EBB)
-> Int
forall a. Hashable a => a -> Int
hash (ChainHash TestHeader
a, TestBodyHash
b, SlotNo
c, BlockNo
d, ChainLength
e, EBB
f))

testBlockIsEBB :: TestBlock -> IsEBB
testBlockIsEBB :: TestBlock -> IsEBB
testBlockIsEBB = Header TestBlock -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB (Header TestBlock -> IsEBB)
-> (TestBlock -> Header TestBlock) -> TestBlock -> IsEBB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader

testBlockChainLength :: TestBlock -> ChainLength
testBlockChainLength :: TestBlock -> ChainLength
testBlockChainLength = TestHeader -> ChainLength
thChainLength (TestHeader -> ChainLength)
-> (TestBlock -> TestHeader) -> TestBlock -> ChainLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header TestBlock -> TestHeader
unTestHeader (Header TestBlock -> TestHeader)
-> (TestBlock -> Header TestBlock) -> TestBlock -> TestHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader

-- | Check whether the header matches its hash and whether the body matches
-- its hash.
testBlockIsValid :: TestBlock -> Bool
testBlockIsValid :: TestBlock -> Bool
testBlockIsValid (TestBlock TestHeader
hdr TestBody
body) =
  TestHeader -> HeaderHash TestHeader
thHash     TestHeader
hdr TestHeaderHash -> TestHeaderHash -> Bool
forall a. Eq a => a -> a -> Bool
== TestHeader -> TestHeaderHash
hashHeader TestHeader
hdr Bool -> Bool -> Bool
&&
  TestHeader -> TestBodyHash
thBodyHash TestHeader
hdr TestBodyHash -> TestBodyHash -> Bool
forall a. Eq a => a -> a -> Bool
== TestBody -> TestBodyHash
hashBody   TestBody
body

testBlockToBuilder :: TestBlock -> Builder
testBlockToBuilder :: TestBlock -> Builder
testBlockToBuilder = Encoding -> Builder
CBOR.toBuilder (Encoding -> Builder)
-> (TestBlock -> Encoding) -> TestBlock -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Encoding
forall a. Serialise a => a -> Encoding
encode

testBlockHeaderOffset :: Word16
testBlockHeaderOffset :: Word16
testBlockHeaderOffset = Word16
2 -- For the 'encodeListLen'

testBlockHeaderSize :: TestBlock -> Word16
testBlockHeaderSize :: TestBlock -> Word16
testBlockHeaderSize = Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> (TestBlock -> Int64) -> TestBlock -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
Lazy.length (ByteString -> Int64)
-> (TestBlock -> ByteString) -> TestBlock -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHeader -> ByteString
forall a. Serialise a => a -> ByteString
serialise (TestHeader -> ByteString)
-> (TestBlock -> TestHeader) -> TestBlock -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> TestHeader
testHeader

testBlockToLazyByteString :: TestBlock -> Lazy.ByteString
testBlockToLazyByteString :: TestBlock -> ByteString
testBlockToLazyByteString = Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString)
-> (TestBlock -> Encoding) -> TestBlock -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Encoding
forall a. Serialise a => a -> Encoding
encode

testBlockFromLazyByteString :: HasCallStack => Lazy.ByteString -> TestBlock
testBlockFromLazyByteString :: HasCallStack => ByteString -> TestBlock
testBlockFromLazyByteString ByteString
bs = case (forall s. Decoder s TestBlock)
-> ByteString -> Either DeserialiseFailure (ByteString, TestBlock)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s TestBlock
forall s. Decoder s TestBlock
forall a s. Serialise a => Decoder s a
decode ByteString
bs of
    Left DeserialiseFailure
e -> String -> TestBlock
forall a. HasCallStack => String -> a
error (String -> TestBlock) -> String -> TestBlock
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
e
    Right (ByteString
bs', TestBlock
a)
      | ByteString -> Bool
Lazy.null ByteString
bs'
      -> TestBlock
a
      | Bool
otherwise
      -> String -> TestBlock
forall a. HasCallStack => String -> a
error (String -> TestBlock) -> String -> TestBlock
forall a b. (a -> b) -> a -> b
$ String
"left-over bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs'

{-------------------------------------------------------------------------------
  Real chain length
-------------------------------------------------------------------------------}

-- | In chain selection, we use 'BlockNo' as a proxy for the block length.
-- This is entirely correct, except for those dreadful EBBs, which share their
-- block number with their predecessor. So it is possible that two chains with
-- the same 'BlockNo' at the tip have a different length because the longer
-- chain contains more EBBs than the shorter.
--
-- For example:
--
-- > .. :> EBB (100, slotNo 10, blockNo 1) :> (400, slotNo 10, blockNo 2)
-- > .. :> (999, slotNo 10, blockNo 2)
--
-- The chain selection for this 'TestBlock' looks at the hashes in case of a
-- 'BlockNo' tie (after prefering the chain ending with an EBB) and will pick
-- the block with the highest hash. This is to have a more deterministic chain
-- selection (less implementation specific) which will keep the model better
-- in sync with the implementation.
--
-- In the example above, that would mean picking the second chain, /even
-- though it is shorter/! The implementation does not support switching to a
-- shorter chain.
--
-- Note that this is not a problem for Byron, because we don't look at the
-- hashes or anything else in case of a tie (we just prefer a chain ending
-- with an EBB, which /must/ be longer).
--
-- Note that is not a problem for Shelley either, where we do look at the
-- certificate number and VRF hash in case of a tie, because there are no EBBs.
--
-- This is only an issue when:
-- * There can be EBBs in the chain
-- * In case of equal 'blockNo's, we still prefer one over the other because
--   of some additional condition.
--
-- Which is the case for this TestBlock.
--
-- To solve this, we store the /real/ chain length inside the block. The only
-- difference with the 'BlockNo' is that 'ChainLength' takes EBBs into account.
--
-- When there is 'BlockNo' tie as in the example above and we would look at
-- the hashes, we will first look at the 'ChainLength' (and prefer the longest
-- one). Only if that is equal do we actually look at the hashes. This
-- guarantees that we never prefer a chain that is shorter.
--
-- NOTE: we start counting from 1 (unlike 'BlockNo', which starts from 0),
-- because it corresponds to the /length/.
newtype ChainLength = ChainLength Int
  deriving stock   (Int -> ChainLength -> ShowS
[ChainLength] -> ShowS
ChainLength -> String
(Int -> ChainLength -> ShowS)
-> (ChainLength -> String)
-> ([ChainLength] -> ShowS)
-> Show ChainLength
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainLength -> ShowS
showsPrec :: Int -> ChainLength -> ShowS
$cshow :: ChainLength -> String
show :: ChainLength -> String
$cshowList :: [ChainLength] -> ShowS
showList :: [ChainLength] -> ShowS
Show, (forall x. ChainLength -> Rep ChainLength x)
-> (forall x. Rep ChainLength x -> ChainLength)
-> Generic ChainLength
forall x. Rep ChainLength x -> ChainLength
forall x. ChainLength -> Rep ChainLength x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainLength -> Rep ChainLength x
from :: forall x. ChainLength -> Rep ChainLength x
$cto :: forall x. Rep ChainLength x -> ChainLength
to :: forall x. Rep ChainLength x -> ChainLength
Generic)
  deriving newtype (ChainLength -> ChainLength -> Bool
(ChainLength -> ChainLength -> Bool)
-> (ChainLength -> ChainLength -> Bool) -> Eq ChainLength
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainLength -> ChainLength -> Bool
== :: ChainLength -> ChainLength -> Bool
$c/= :: ChainLength -> ChainLength -> Bool
/= :: ChainLength -> ChainLength -> Bool
Eq, Eq ChainLength
Eq ChainLength =>
(ChainLength -> ChainLength -> Ordering)
-> (ChainLength -> ChainLength -> Bool)
-> (ChainLength -> ChainLength -> Bool)
-> (ChainLength -> ChainLength -> Bool)
-> (ChainLength -> ChainLength -> Bool)
-> (ChainLength -> ChainLength -> ChainLength)
-> (ChainLength -> ChainLength -> ChainLength)
-> Ord ChainLength
ChainLength -> ChainLength -> Bool
ChainLength -> ChainLength -> Ordering
ChainLength -> ChainLength -> ChainLength
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ChainLength -> ChainLength -> Ordering
compare :: ChainLength -> ChainLength -> Ordering
$c< :: ChainLength -> ChainLength -> Bool
< :: ChainLength -> ChainLength -> Bool
$c<= :: ChainLength -> ChainLength -> Bool
<= :: ChainLength -> ChainLength -> Bool
$c> :: ChainLength -> ChainLength -> Bool
> :: ChainLength -> ChainLength -> Bool
$c>= :: ChainLength -> ChainLength -> Bool
>= :: ChainLength -> ChainLength -> Bool
$cmax :: ChainLength -> ChainLength -> ChainLength
max :: ChainLength -> ChainLength -> ChainLength
$cmin :: ChainLength -> ChainLength -> ChainLength
min :: ChainLength -> ChainLength -> ChainLength
Ord, Int -> ChainLength
ChainLength -> Int
ChainLength -> [ChainLength]
ChainLength -> ChainLength
ChainLength -> ChainLength -> [ChainLength]
ChainLength -> ChainLength -> ChainLength -> [ChainLength]
(ChainLength -> ChainLength)
-> (ChainLength -> ChainLength)
-> (Int -> ChainLength)
-> (ChainLength -> Int)
-> (ChainLength -> [ChainLength])
-> (ChainLength -> ChainLength -> [ChainLength])
-> (ChainLength -> ChainLength -> [ChainLength])
-> (ChainLength -> ChainLength -> ChainLength -> [ChainLength])
-> Enum ChainLength
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ChainLength -> ChainLength
succ :: ChainLength -> ChainLength
$cpred :: ChainLength -> ChainLength
pred :: ChainLength -> ChainLength
$ctoEnum :: Int -> ChainLength
toEnum :: Int -> ChainLength
$cfromEnum :: ChainLength -> Int
fromEnum :: ChainLength -> Int
$cenumFrom :: ChainLength -> [ChainLength]
enumFrom :: ChainLength -> [ChainLength]
$cenumFromThen :: ChainLength -> ChainLength -> [ChainLength]
enumFromThen :: ChainLength -> ChainLength -> [ChainLength]
$cenumFromTo :: ChainLength -> ChainLength -> [ChainLength]
enumFromTo :: ChainLength -> ChainLength -> [ChainLength]
$cenumFromThenTo :: ChainLength -> ChainLength -> ChainLength -> [ChainLength]
enumFromThenTo :: ChainLength -> ChainLength -> ChainLength -> [ChainLength]
Enum, Context -> ChainLength -> IO (Maybe ThunkInfo)
Proxy ChainLength -> String
(Context -> ChainLength -> IO (Maybe ThunkInfo))
-> (Context -> ChainLength -> IO (Maybe ThunkInfo))
-> (Proxy ChainLength -> String)
-> NoThunks ChainLength
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ChainLength -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainLength -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainLength -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainLength -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ChainLength -> String
showTypeOf :: Proxy ChainLength -> String
NoThunks, [ChainLength] -> Encoding
ChainLength -> Encoding
(ChainLength -> Encoding)
-> (forall s. Decoder s ChainLength)
-> ([ChainLength] -> Encoding)
-> (forall s. Decoder s [ChainLength])
-> Serialise ChainLength
forall s. Decoder s [ChainLength]
forall s. Decoder s ChainLength
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: ChainLength -> Encoding
encode :: ChainLength -> Encoding
$cdecode :: forall s. Decoder s ChainLength
decode :: forall s. Decoder s ChainLength
$cencodeList :: [ChainLength] -> Encoding
encodeList :: [ChainLength] -> Encoding
$cdecodeList :: forall s. Decoder s [ChainLength]
decodeList :: forall s. Decoder s [ChainLength]
Serialise, Eq ChainLength
Eq ChainLength =>
(Int -> ChainLength -> Int)
-> (ChainLength -> Int) -> Hashable ChainLength
Int -> ChainLength -> Int
ChainLength -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> ChainLength -> Int
hashWithSalt :: Int -> ChainLength -> Int
$chash :: ChainLength -> Int
hash :: ChainLength -> Int
Hashable)

{-------------------------------------------------------------------------------
  Creating blocks
-------------------------------------------------------------------------------}

mkBlock ::
     HasCallStack
  => (SlotNo -> Bool)
  -- ^ Is this slot allowed contain an EBB?
  --
  -- This argument is used primarily to detect the generation of invalid blocks
  -- with different kind of 'ChunkInfo'.
  -> TestBody
  -> ChainHash TestHeader
  -- ^ Hash of previous header
  -> SlotNo
  -> BlockNo
  -> ChainLength
  -> Maybe EpochNo
  -> TestBlock
mkBlock :: HasCallStack =>
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
mkBlock SlotNo -> Bool
canContainEBB TestBody
testBody ChainHash TestHeader
thPrevHash SlotNo
thSlotNo BlockNo
thBlockNo ChainLength
thChainLength Maybe EpochNo
ebb =
    case (SlotNo -> Bool
canContainEBB SlotNo
thSlotNo, Maybe EpochNo
ebb) of
      (Bool
False, Just EpochNo
_) ->
        String -> TestBlock
forall a. HasCallStack => String -> a
error String
"mkBlock: EBB in invalid slot"
      (Bool, Maybe EpochNo)
_otherwise ->
        TestBlock { TestHeader
testHeader :: TestHeader
testHeader :: TestHeader
testHeader, TestBody
testBody :: TestBody
testBody :: TestBody
testBody }
  where
    testHeader :: TestHeader
testHeader = TestHeader {
        thHash :: HeaderHash TestHeader
thHash     = TestHeader -> TestHeaderHash
hashHeader TestHeader
testHeader
      , ChainHash TestHeader
thPrevHash :: ChainHash TestHeader
thPrevHash :: ChainHash TestHeader
thPrevHash
      , thBodyHash :: TestBodyHash
thBodyHash = TestBody -> TestBodyHash
hashBody TestBody
testBody
      , SlotNo
thSlotNo :: SlotNo
thSlotNo :: SlotNo
thSlotNo
      , BlockNo
thBlockNo :: BlockNo
thBlockNo :: BlockNo
thBlockNo
      , ChainLength
thChainLength :: ChainLength
thChainLength :: ChainLength
thChainLength
      , thIsEBB :: EBB
thIsEBB = case Maybe EpochNo
ebb of
          Just EpochNo
epoch -> EpochNo -> EBB
EBB EpochNo
epoch
          Maybe EpochNo
Nothing    -> EBB
RegularBlock
      }

-- | Note the first block need not be an EBB, see 'firstEBB'.
firstBlock :: SlotNo -> TestBody -> TestBlock
firstBlock :: SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
slotNo TestBody
testBody =
    HasCallStack =>
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
mkBlock
      (Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
False)
      TestBody
testBody
      ChainHash TestHeader
forall {k} (b :: k). ChainHash b
GenesisHash
      SlotNo
slotNo
      BlockNo
0
      (Int -> ChainLength
ChainLength Int
1)
      Maybe EpochNo
forall a. Maybe a
Nothing

mkNextBlock' ::
     (HeaderFields TestBlock, ChainLength)
     -- ^ Information about the previous block
  -> SlotNo
  -> TestBody
  -> TestBlock
mkNextBlock' :: (HeaderFields TestBlock, ChainLength)
-> SlotNo -> TestBody -> TestBlock
mkNextBlock' (HeaderFields TestBlock
prevHeaderFields, ChainLength
prevChainLength) SlotNo
slotNo TestBody
testBody =
    HasCallStack =>
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
mkBlock
      (Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
False)
      TestBody
testBody
      (HeaderHash TestHeader -> ChainHash TestHeader
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderFields TestBlock -> HeaderHash TestBlock
forall k (b :: k). HeaderFields b -> HeaderHash b
headerFieldHash HeaderFields TestBlock
prevHeaderFields))
      SlotNo
slotNo
      (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ (HeaderFields TestBlock -> BlockNo
forall k (b :: k). HeaderFields b -> BlockNo
headerFieldBlockNo HeaderFields TestBlock
prevHeaderFields))
      (ChainLength -> ChainLength
forall a. Enum a => a -> a
succ ChainLength
prevChainLength)
      Maybe EpochNo
forall a. Maybe a
Nothing

firstEBB :: (SlotNo -> Bool)
         -> TestBody
         -> TestBlock
firstEBB :: (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
canContainEBB TestBody
testBody =
    HasCallStack =>
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
mkBlock SlotNo -> Bool
canContainEBB TestBody
testBody ChainHash TestHeader
forall {k} (b :: k). ChainHash b
GenesisHash SlotNo
0 BlockNo
0 (Int -> ChainLength
ChainLength Int
1) (EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
0)

-- | Note that in various places, e.g., the ImmutableDB, we rely on the fact
-- that the @slotNo@ should correspond to the first slot number of the epoch,
-- as is the case for real EBBs.
mkNextEBB' ::
     (SlotNo -> Bool)
  -> (HeaderFields TestBlock, ChainLength)
     -- ^ Information about the previous block
  -> SlotNo
  -> EpochNo
  -> TestBody
  -> TestBlock
mkNextEBB' :: (SlotNo -> Bool)
-> (HeaderFields TestBlock, ChainLength)
-> SlotNo
-> EpochNo
-> TestBody
-> TestBlock
mkNextEBB' SlotNo -> Bool
canContainEBB (HeaderFields TestBlock
prevHeaderFields, ChainLength
prevChainLength) SlotNo
slotNo EpochNo
epochNo TestBody
testBody =
    HasCallStack =>
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
(SlotNo -> Bool)
-> TestBody
-> ChainHash TestHeader
-> SlotNo
-> BlockNo
-> ChainLength
-> Maybe EpochNo
-> TestBlock
mkBlock
      SlotNo -> Bool
canContainEBB
      TestBody
testBody
      (HeaderHash TestHeader -> ChainHash TestHeader
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderFields TestBlock -> HeaderHash TestBlock
forall k (b :: k). HeaderFields b -> HeaderHash b
headerFieldHash HeaderFields TestBlock
prevHeaderFields))
      SlotNo
slotNo
      (HeaderFields TestBlock -> BlockNo
forall k (b :: k). HeaderFields b -> BlockNo
headerFieldBlockNo HeaderFields TestBlock
prevHeaderFields)
      (ChainLength -> ChainLength
forall a. Enum a => a -> a
succ ChainLength
prevChainLength)
      (EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epochNo)

-- | Variant of 'mkNextBlock' that takes the entire previous block.
mkNextBlock ::
     TestBlock
     -- ^ Previous block
  -> SlotNo
  -> TestBody
  -> TestBlock
mkNextBlock :: TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
tb =
    (HeaderFields TestBlock, ChainLength)
-> SlotNo -> TestBody -> TestBlock
mkNextBlock' (TestBlock -> HeaderFields TestBlock
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields TestBlock
tb, TestBlock -> ChainLength
testBlockChainLength TestBlock
tb)

-- | Variant of 'mkNextEBB' that takes the entire previous block.
mkNextEBB ::
     (SlotNo -> Bool)
  -> TestBlock
     -- ^ Previous block
  -> SlotNo
  -> EpochNo
  -> TestBody
  -> TestBlock
mkNextEBB :: (SlotNo -> Bool)
-> TestBlock -> SlotNo -> EpochNo -> TestBody -> TestBlock
mkNextEBB SlotNo -> Bool
canContainEBB TestBlock
tb =
    (SlotNo -> Bool)
-> (HeaderFields TestBlock, ChainLength)
-> SlotNo
-> EpochNo
-> TestBody
-> TestBlock
mkNextEBB' SlotNo -> Bool
canContainEBB (TestBlock -> HeaderFields TestBlock
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields TestBlock
tb, TestBlock -> ChainLength
testBlockChainLength TestBlock
tb)

{-------------------------------------------------------------------------------
  Test infrastructure: protocol
-------------------------------------------------------------------------------}

data BftWithEBBsSelectView = BftWithEBBsSelectView {
      BftWithEBBsSelectView -> BlockNo
bebbBlockNo     :: !BlockNo
    , BftWithEBBsSelectView -> IsEBB
bebbIsEBB       :: !IsEBB
    , BftWithEBBsSelectView -> ChainLength
bebbChainLength :: !ChainLength
    , BftWithEBBsSelectView -> TestHeaderHash
bebbHash        :: !TestHeaderHash
    }
  deriving stock (Int -> BftWithEBBsSelectView -> ShowS
[BftWithEBBsSelectView] -> ShowS
BftWithEBBsSelectView -> String
(Int -> BftWithEBBsSelectView -> ShowS)
-> (BftWithEBBsSelectView -> String)
-> ([BftWithEBBsSelectView] -> ShowS)
-> Show BftWithEBBsSelectView
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BftWithEBBsSelectView -> ShowS
showsPrec :: Int -> BftWithEBBsSelectView -> ShowS
$cshow :: BftWithEBBsSelectView -> String
show :: BftWithEBBsSelectView -> String
$cshowList :: [BftWithEBBsSelectView] -> ShowS
showList :: [BftWithEBBsSelectView] -> ShowS
Show, BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
(BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool)
-> (BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool)
-> Eq BftWithEBBsSelectView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
== :: BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
$c/= :: BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
/= :: BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
Eq, (forall x. BftWithEBBsSelectView -> Rep BftWithEBBsSelectView x)
-> (forall x. Rep BftWithEBBsSelectView x -> BftWithEBBsSelectView)
-> Generic BftWithEBBsSelectView
forall x. Rep BftWithEBBsSelectView x -> BftWithEBBsSelectView
forall x. BftWithEBBsSelectView -> Rep BftWithEBBsSelectView x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BftWithEBBsSelectView -> Rep BftWithEBBsSelectView x
from :: forall x. BftWithEBBsSelectView -> Rep BftWithEBBsSelectView x
$cto :: forall x. Rep BftWithEBBsSelectView x -> BftWithEBBsSelectView
to :: forall x. Rep BftWithEBBsSelectView x -> BftWithEBBsSelectView
Generic)
  deriving anyclass (Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo)
Proxy BftWithEBBsSelectView -> String
(Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo))
-> (Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo))
-> (Proxy BftWithEBBsSelectView -> String)
-> NoThunks BftWithEBBsSelectView
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo)
noThunks :: Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BftWithEBBsSelectView -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy BftWithEBBsSelectView -> String
showTypeOf :: Proxy BftWithEBBsSelectView -> String
NoThunks)
  deriving (Ord BftWithEBBsSelectView
Ord BftWithEBBsSelectView =>
(ChainOrderConfig BftWithEBBsSelectView
 -> BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool)
-> ChainOrder BftWithEBBsSelectView
ChainOrderConfig BftWithEBBsSelectView
-> BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
forall sv.
Ord sv =>
(ChainOrderConfig sv -> sv -> sv -> Bool) -> ChainOrder sv
$cpreferCandidate :: ChainOrderConfig BftWithEBBsSelectView
-> BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
preferCandidate :: ChainOrderConfig BftWithEBBsSelectView
-> BftWithEBBsSelectView -> BftWithEBBsSelectView -> Bool
ChainOrder) via SimpleChainOrder BftWithEBBsSelectView

instance Ord BftWithEBBsSelectView where
  compare :: BftWithEBBsSelectView -> BftWithEBBsSelectView -> Ordering
compare (BftWithEBBsSelectView BlockNo
lBlockNo IsEBB
lIsEBB ChainLength
lChainLength TestHeaderHash
lHash)
          (BftWithEBBsSelectView BlockNo
rBlockNo IsEBB
rIsEBB ChainLength
rChainLength TestHeaderHash
rHash) =
      [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat [
          -- Prefer the highest block number, as it is a proxy for chain length
          BlockNo
lBlockNo BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` BlockNo
rBlockNo

          -- If the block numbers are the same, check if one of them is an EBB.
          -- An EBB has the same block number as the block before it, so the
          -- chain ending with an EBB is actually longer than the one ending
          -- with a regular block.
        , IsEBB -> Int
score IsEBB
lIsEBB Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` IsEBB -> Int
score IsEBB
rIsEBB

          -- In case of a tie, look at the real chain length, so that we never
          -- prefer a shorter chain over a longer one, see 'ChainLength'.
        , ChainLength
lChainLength ChainLength -> ChainLength -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ChainLength
rChainLength

        -- In case of another tie, pick the largest hash, so that the model and
        -- the implementation will make the same choice, regardless
        -- implementation details (e.g., sort order).
        , TestHeaderHash
lHash        TestHeaderHash -> TestHeaderHash -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TestHeaderHash
rHash
        ]
   where
     score :: IsEBB -> Int
     score :: IsEBB -> Int
score IsEBB
IsEBB    = Int
1
     score IsEBB
IsNotEBB = Int
0

type instance BlockProtocol TestBlock =
  ModChainSel (Bft BftMockCrypto) BftWithEBBsSelectView

{-------------------------------------------------------------------------------
  Test infrastructure: ledger state
-------------------------------------------------------------------------------}

type instance Signed (Header TestBlock) = ()
instance SignedHeader (Header TestBlock) where
  headerSigned :: Header TestBlock -> Signed (Header TestBlock)
headerSigned Header TestBlock
_ = ()

instance BlockSupportsProtocol TestBlock where
  validateView :: BlockConfig TestBlock
-> Header TestBlock -> ValidateView (BlockProtocol TestBlock)
validateView TestBlockConfig{Bool
NumCoreNodes
testBlockEBBsAllowed :: BlockConfig TestBlock -> Bool
testBlockNumCoreNodes :: BlockConfig TestBlock -> NumCoreNodes
testBlockEBBsAllowed :: Bool
testBlockNumCoreNodes :: NumCoreNodes
..} =
      (Header TestBlock
 -> BftFields BftMockCrypto (Signed (Header TestBlock)))
-> Header TestBlock -> BftValidateView BftMockCrypto
forall hdr c.
(SignedHeader hdr, Signable (BftDSIGN c) (Signed hdr)) =>
(hdr -> BftFields c (Signed hdr)) -> hdr -> BftValidateView c
bftValidateView Header TestBlock -> BftFields BftMockCrypto ()
Header TestBlock
-> BftFields BftMockCrypto (Signed (Header TestBlock))
bftFields
    where
      NumCoreNodes Word64
numCore = NumCoreNodes
testBlockNumCoreNodes

      bftFields :: Header TestBlock -> BftFields BftMockCrypto ()
      bftFields :: Header TestBlock -> BftFields BftMockCrypto ()
bftFields Header TestBlock
hdr = BftFields {
            bftSignature :: SignedDSIGN (BftDSIGN BftMockCrypto) ()
bftSignature = SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ()
forall v a. SigDSIGN v -> SignedDSIGN v a
SignedDSIGN (SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ())
-> SigDSIGN MockDSIGN -> SignedDSIGN MockDSIGN ()
forall a b. (a -> b) -> a -> b
$ () -> SignKeyDSIGN MockDSIGN -> SigDSIGN MockDSIGN
forall a.
SignableRepresentation a =>
a -> SignKeyDSIGN MockDSIGN -> SigDSIGN MockDSIGN
mockSign () (SlotNo -> SignKeyDSIGN MockDSIGN
signKey (Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
hdr))
          }

      -- We don't want /our/ signing key, but rather the signing key of the
      -- node that produced the block
      signKey :: SlotNo -> SignKeyDSIGN MockDSIGN
      signKey :: SlotNo -> SignKeyDSIGN MockDSIGN
signKey (SlotNo Word64
n) = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN (Word64 -> SignKeyDSIGN MockDSIGN)
-> Word64 -> SignKeyDSIGN MockDSIGN
forall a b. (a -> b) -> a -> b
$ Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
numCore

  selectView :: BlockConfig TestBlock
-> Header TestBlock -> SelectView (BlockProtocol TestBlock)
selectView BlockConfig TestBlock
_ Header TestBlock
hdr = BftWithEBBsSelectView {
        bebbBlockNo :: BlockNo
bebbBlockNo     = Header TestBlock -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header TestBlock
hdr
      , bebbIsEBB :: IsEBB
bebbIsEBB       = Header TestBlock -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header TestBlock
hdr
      , bebbChainLength :: ChainLength
bebbChainLength = TestHeader -> ChainLength
thChainLength (Header TestBlock -> TestHeader
unTestHeader Header TestBlock
hdr)
      , bebbHash :: TestHeaderHash
bebbHash        = Header TestBlock -> HeaderHash (Header TestBlock)
forall b. HasHeader b => b -> HeaderHash b
blockHash Header TestBlock
hdr
      }

data TestBlockError =
    -- | The hashes don't line up
    InvalidHash
      (ChainHash TestBlock)  -- ^ Expected hash
      (ChainHash TestBlock)  -- ^ Invalid hash

    -- | The block itself is invalid
  | InvalidBlock
  deriving (TestBlockError -> TestBlockError -> Bool
(TestBlockError -> TestBlockError -> Bool)
-> (TestBlockError -> TestBlockError -> Bool) -> Eq TestBlockError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBlockError -> TestBlockError -> Bool
== :: TestBlockError -> TestBlockError -> Bool
$c/= :: TestBlockError -> TestBlockError -> Bool
/= :: TestBlockError -> TestBlockError -> Bool
Eq, Int -> TestBlockError -> ShowS
[TestBlockError] -> ShowS
TestBlockError -> String
(Int -> TestBlockError -> ShowS)
-> (TestBlockError -> String)
-> ([TestBlockError] -> ShowS)
-> Show TestBlockError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlockError -> ShowS
showsPrec :: Int -> TestBlockError -> ShowS
$cshow :: TestBlockError -> String
show :: TestBlockError -> String
$cshowList :: [TestBlockError] -> ShowS
showList :: [TestBlockError] -> ShowS
Show, (forall x. TestBlockError -> Rep TestBlockError x)
-> (forall x. Rep TestBlockError x -> TestBlockError)
-> Generic TestBlockError
forall x. Rep TestBlockError x -> TestBlockError
forall x. TestBlockError -> Rep TestBlockError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestBlockError -> Rep TestBlockError x
from :: forall x. TestBlockError -> Rep TestBlockError x
$cto :: forall x. Rep TestBlockError x -> TestBlockError
to :: forall x. Rep TestBlockError x -> TestBlockError
Generic, Context -> TestBlockError -> IO (Maybe ThunkInfo)
Proxy TestBlockError -> String
(Context -> TestBlockError -> IO (Maybe ThunkInfo))
-> (Context -> TestBlockError -> IO (Maybe ThunkInfo))
-> (Proxy TestBlockError -> String)
-> NoThunks TestBlockError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TestBlockError -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestBlockError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TestBlockError -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestBlockError -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBlockError -> String
showTypeOf :: Proxy TestBlockError -> String
NoThunks)

type instance LedgerCfg (LedgerState TestBlock) = HardFork.EraParams

instance GetTip (LedgerState TestBlock) where
  getTip :: LedgerState TestBlock -> Point (LedgerState TestBlock)
getTip = Point TestBlock -> Point (LedgerState TestBlock)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point TestBlock -> Point (LedgerState TestBlock))
-> (LedgerState TestBlock -> Point TestBlock)
-> LedgerState TestBlock
-> Point (LedgerState TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState TestBlock -> Point TestBlock
lastAppliedPoint

instance GetTip (Ticked (LedgerState TestBlock)) where
  getTip :: Ticked (LedgerState TestBlock)
-> Point (Ticked (LedgerState TestBlock))
getTip = Point (LedgerState TestBlock)
-> Point (Ticked (LedgerState TestBlock))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState TestBlock)
 -> Point (Ticked (LedgerState TestBlock)))
-> (Ticked (LedgerState TestBlock)
    -> Point (LedgerState TestBlock))
-> Ticked (LedgerState TestBlock)
-> Point (Ticked (LedgerState TestBlock))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState TestBlock -> Point (LedgerState TestBlock)
forall l. GetTip l => l -> Point l
getTip (LedgerState TestBlock -> Point (LedgerState TestBlock))
-> (Ticked (LedgerState TestBlock) -> LedgerState TestBlock)
-> Ticked (LedgerState TestBlock)
-> Point (LedgerState TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState TestBlock) -> LedgerState TestBlock
getTickedTestLedger

instance IsLedger (LedgerState TestBlock) where
  type LedgerErr (LedgerState TestBlock) = TestBlockError

  type AuxLedgerEvent (LedgerState TestBlock) =
    VoidLedgerEvent (LedgerState TestBlock)

  applyChainTickLedgerResult :: LedgerCfg (LedgerState TestBlock)
-> SlotNo
-> LedgerState TestBlock
-> LedgerResult
     (LedgerState TestBlock) (Ticked (LedgerState TestBlock))
applyChainTickLedgerResult LedgerCfg (LedgerState TestBlock)
_ SlotNo
_ = Ticked (LedgerState TestBlock)
-> LedgerResult
     (LedgerState TestBlock) (Ticked (LedgerState TestBlock))
forall a l. a -> LedgerResult l a
pureLedgerResult (Ticked (LedgerState TestBlock)
 -> LedgerResult
      (LedgerState TestBlock) (Ticked (LedgerState TestBlock)))
-> (LedgerState TestBlock -> Ticked (LedgerState TestBlock))
-> LedgerState TestBlock
-> LedgerResult
     (LedgerState TestBlock) (Ticked (LedgerState TestBlock))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState TestBlock -> Ticked (LedgerState TestBlock)
TickedTestLedger

instance ApplyBlock (LedgerState TestBlock) TestBlock where
  applyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState TestBlock)
-> TestBlock
-> Ticked (LedgerState TestBlock)
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
applyBlockLedgerResult LedgerCfg (LedgerState TestBlock)
_ tb :: TestBlock
tb@TestBlock{TestBody
TestHeader
testHeader :: TestBlock -> TestHeader
testBody :: TestBlock -> TestBody
testHeader :: TestHeader
testBody :: TestBody
..} (TickedTestLedger TestLedger{Point TestBlock
ChainHash TestBlock
lastAppliedPoint :: LedgerState TestBlock -> Point TestBlock
lastAppliedPoint :: Point TestBlock
lastAppliedHash :: ChainHash TestBlock
lastAppliedHash :: LedgerState TestBlock -> ChainHash TestBlock
..})
    | TestBlock -> ChainHash TestBlock
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash TestBlock
tb ChainHash TestBlock -> ChainHash TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainHash TestBlock
lastAppliedHash
    = TestBlockError
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a.
TestBlockError
-> ExceptT (LedgerErr (LedgerState TestBlock)) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockError
 -> Except
      (LedgerErr (LedgerState TestBlock))
      (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)))
-> TestBlockError
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ ChainHash TestBlock -> ChainHash TestBlock -> TestBlockError
InvalidHash ChainHash TestBlock
lastAppliedHash (TestBlock -> ChainHash TestBlock
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash TestBlock
tb)
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestBody -> Bool
tbIsValid TestBody
testBody
    = TestBlockError
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a.
TestBlockError
-> ExceptT (LedgerErr (LedgerState TestBlock)) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockError
 -> Except
      (LedgerErr (LedgerState TestBlock))
      (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)))
-> TestBlockError
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ TestBlockError
InvalidBlock
    | Bool
otherwise
    = LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a.
a -> ExceptT (LedgerErr (LedgerState TestBlock)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
 -> Except
      (LedgerErr (LedgerState TestBlock))
      (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)))
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
-> Except
     (LedgerErr (LedgerState TestBlock))
     (LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
forall a b. (a -> b) -> a -> b
$ LedgerState TestBlock
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
forall a l. a -> LedgerResult l a
pureLedgerResult (LedgerState TestBlock
 -> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
-> LedgerState TestBlock
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ Point TestBlock -> ChainHash TestBlock -> LedgerState TestBlock
TestLedger (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
Chain.blockPoint TestBlock
tb) (HeaderHash TestBlock -> ChainHash TestBlock
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
tb))

  reapplyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState TestBlock)
-> TestBlock
-> Ticked (LedgerState TestBlock)
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
reapplyBlockLedgerResult LedgerCfg (LedgerState TestBlock)
_ TestBlock
tb Ticked (LedgerState TestBlock)
_ =
                   LedgerState TestBlock
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
forall a l. a -> LedgerResult l a
pureLedgerResult (LedgerState TestBlock
 -> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock))
-> LedgerState TestBlock
-> LedgerResult (LedgerState TestBlock) (LedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ Point TestBlock -> ChainHash TestBlock -> LedgerState TestBlock
TestLedger (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
Chain.blockPoint TestBlock
tb) (HeaderHash TestBlock -> ChainHash TestBlock
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
tb))

data instance LedgerState TestBlock =
    TestLedger {
        -- The ledger state simply consists of the last applied block
        LedgerState TestBlock -> Point TestBlock
lastAppliedPoint :: !(Point TestBlock)
      , LedgerState TestBlock -> ChainHash TestBlock
lastAppliedHash  :: !(ChainHash TestBlock)
      }
  deriving stock    (Int -> LedgerState TestBlock -> ShowS
[LedgerState TestBlock] -> ShowS
LedgerState TestBlock -> String
(Int -> LedgerState TestBlock -> ShowS)
-> (LedgerState TestBlock -> String)
-> ([LedgerState TestBlock] -> ShowS)
-> Show (LedgerState TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerState TestBlock -> ShowS
showsPrec :: Int -> LedgerState TestBlock -> ShowS
$cshow :: LedgerState TestBlock -> String
show :: LedgerState TestBlock -> String
$cshowList :: [LedgerState TestBlock] -> ShowS
showList :: [LedgerState TestBlock] -> ShowS
Show, LedgerState TestBlock -> LedgerState TestBlock -> Bool
(LedgerState TestBlock -> LedgerState TestBlock -> Bool)
-> (LedgerState TestBlock -> LedgerState TestBlock -> Bool)
-> Eq (LedgerState TestBlock)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerState TestBlock -> LedgerState TestBlock -> Bool
== :: LedgerState TestBlock -> LedgerState TestBlock -> Bool
$c/= :: LedgerState TestBlock -> LedgerState TestBlock -> Bool
/= :: LedgerState TestBlock -> LedgerState TestBlock -> Bool
Eq, (forall x. LedgerState TestBlock -> Rep (LedgerState TestBlock) x)
-> (forall x.
    Rep (LedgerState TestBlock) x -> LedgerState TestBlock)
-> Generic (LedgerState TestBlock)
forall x. Rep (LedgerState TestBlock) x -> LedgerState TestBlock
forall x. LedgerState TestBlock -> Rep (LedgerState TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LedgerState TestBlock -> Rep (LedgerState TestBlock) x
from :: forall x. LedgerState TestBlock -> Rep (LedgerState TestBlock) x
$cto :: forall x. Rep (LedgerState TestBlock) x -> LedgerState TestBlock
to :: forall x. Rep (LedgerState TestBlock) x -> LedgerState TestBlock
Generic)
  deriving anyclass ([LedgerState TestBlock] -> Encoding
LedgerState TestBlock -> Encoding
(LedgerState TestBlock -> Encoding)
-> (forall s. Decoder s (LedgerState TestBlock))
-> ([LedgerState TestBlock] -> Encoding)
-> (forall s. Decoder s [LedgerState TestBlock])
-> Serialise (LedgerState TestBlock)
forall s. Decoder s [LedgerState TestBlock]
forall s. Decoder s (LedgerState TestBlock)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: LedgerState TestBlock -> Encoding
encode :: LedgerState TestBlock -> Encoding
$cdecode :: forall s. Decoder s (LedgerState TestBlock)
decode :: forall s. Decoder s (LedgerState TestBlock)
$cencodeList :: [LedgerState TestBlock] -> Encoding
encodeList :: [LedgerState TestBlock] -> Encoding
$cdecodeList :: forall s. Decoder s [LedgerState TestBlock]
decodeList :: forall s. Decoder s [LedgerState TestBlock]
Serialise, Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo)
Proxy (LedgerState TestBlock) -> String
(Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerState TestBlock) -> String)
-> NoThunks (LedgerState TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerState TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (LedgerState TestBlock) -> String
showTypeOf :: Proxy (LedgerState TestBlock) -> String
NoThunks)

-- Ticking has no effect on the test ledger state
newtype instance Ticked (LedgerState TestBlock) = TickedTestLedger {
      Ticked (LedgerState TestBlock) -> LedgerState TestBlock
getTickedTestLedger :: LedgerState TestBlock
    }

instance UpdateLedger TestBlock

instance HasAnnTip TestBlock where
  type TipInfo TestBlock = TipInfoIsEBB TestBlock
  tipInfoHash :: forall (proxy :: * -> *).
proxy TestBlock -> TipInfo TestBlock -> HeaderHash TestBlock
tipInfoHash proxy TestBlock
_ (TipInfoIsEBB HeaderHash TestBlock
h IsEBB
_) = HeaderHash TestBlock
h
  getTipInfo :: Header TestBlock -> TipInfo TestBlock
getTipInfo Header TestBlock
b = HeaderHash TestBlock -> IsEBB -> TipInfoIsEBB TestBlock
forall blk. HeaderHash blk -> IsEBB -> TipInfoIsEBB blk
TipInfoIsEBB (Header TestBlock -> HeaderHash (Header TestBlock)
forall b. HasHeader b => b -> HeaderHash b
blockHash Header TestBlock
b) (Header TestBlock -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header TestBlock
b)

data TestBlockOtherHeaderEnvelopeError =
    UnexpectedEBBInSlot !SlotNo
  deriving (TestBlockOtherHeaderEnvelopeError
-> TestBlockOtherHeaderEnvelopeError -> Bool
(TestBlockOtherHeaderEnvelopeError
 -> TestBlockOtherHeaderEnvelopeError -> Bool)
-> (TestBlockOtherHeaderEnvelopeError
    -> TestBlockOtherHeaderEnvelopeError -> Bool)
-> Eq TestBlockOtherHeaderEnvelopeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestBlockOtherHeaderEnvelopeError
-> TestBlockOtherHeaderEnvelopeError -> Bool
== :: TestBlockOtherHeaderEnvelopeError
-> TestBlockOtherHeaderEnvelopeError -> Bool
$c/= :: TestBlockOtherHeaderEnvelopeError
-> TestBlockOtherHeaderEnvelopeError -> Bool
/= :: TestBlockOtherHeaderEnvelopeError
-> TestBlockOtherHeaderEnvelopeError -> Bool
Eq, Int -> TestBlockOtherHeaderEnvelopeError -> ShowS
[TestBlockOtherHeaderEnvelopeError] -> ShowS
TestBlockOtherHeaderEnvelopeError -> String
(Int -> TestBlockOtherHeaderEnvelopeError -> ShowS)
-> (TestBlockOtherHeaderEnvelopeError -> String)
-> ([TestBlockOtherHeaderEnvelopeError] -> ShowS)
-> Show TestBlockOtherHeaderEnvelopeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestBlockOtherHeaderEnvelopeError -> ShowS
showsPrec :: Int -> TestBlockOtherHeaderEnvelopeError -> ShowS
$cshow :: TestBlockOtherHeaderEnvelopeError -> String
show :: TestBlockOtherHeaderEnvelopeError -> String
$cshowList :: [TestBlockOtherHeaderEnvelopeError] -> ShowS
showList :: [TestBlockOtherHeaderEnvelopeError] -> ShowS
Show, (forall x.
 TestBlockOtherHeaderEnvelopeError
 -> Rep TestBlockOtherHeaderEnvelopeError x)
-> (forall x.
    Rep TestBlockOtherHeaderEnvelopeError x
    -> TestBlockOtherHeaderEnvelopeError)
-> Generic TestBlockOtherHeaderEnvelopeError
forall x.
Rep TestBlockOtherHeaderEnvelopeError x
-> TestBlockOtherHeaderEnvelopeError
forall x.
TestBlockOtherHeaderEnvelopeError
-> Rep TestBlockOtherHeaderEnvelopeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TestBlockOtherHeaderEnvelopeError
-> Rep TestBlockOtherHeaderEnvelopeError x
from :: forall x.
TestBlockOtherHeaderEnvelopeError
-> Rep TestBlockOtherHeaderEnvelopeError x
$cto :: forall x.
Rep TestBlockOtherHeaderEnvelopeError x
-> TestBlockOtherHeaderEnvelopeError
to :: forall x.
Rep TestBlockOtherHeaderEnvelopeError x
-> TestBlockOtherHeaderEnvelopeError
Generic, Context
-> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
Proxy TestBlockOtherHeaderEnvelopeError -> String
(Context
 -> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo))
-> (Context
    -> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo))
-> (Proxy TestBlockOtherHeaderEnvelopeError -> String)
-> NoThunks TestBlockOtherHeaderEnvelopeError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context
-> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
noThunks :: Context
-> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context
-> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> TestBlockOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TestBlockOtherHeaderEnvelopeError -> String
showTypeOf :: Proxy TestBlockOtherHeaderEnvelopeError -> String
NoThunks)

instance BasicEnvelopeValidation TestBlock where
  minimumPossibleSlotNo :: Proxy TestBlock -> SlotNo
minimumPossibleSlotNo Proxy TestBlock
_ = Word64 -> SlotNo
SlotNo Word64
0

  -- EBB shares its slot number with its successor
  minimumNextSlotNo :: forall (proxy :: * -> *).
proxy TestBlock
-> TipInfo TestBlock -> TipInfo TestBlock -> SlotNo -> SlotNo
minimumNextSlotNo proxy TestBlock
_ (TipInfoIsEBB HeaderHash TestBlock
_ IsEBB
prevIsEBB) (TipInfoIsEBB HeaderHash TestBlock
_ IsEBB
curIsEBB) SlotNo
s =
      case (IsEBB
prevIsEBB, IsEBB
curIsEBB) of
        (IsEBB
IsEBB, IsEBB
IsNotEBB) -> SlotNo
s
        (IsEBB, IsEBB)
_otherwise        -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

  -- The chain always starts with block number 0.
  expectedFirstBlockNo :: forall (proxy :: * -> *). proxy TestBlock -> BlockNo
expectedFirstBlockNo proxy TestBlock
_ = Word64 -> BlockNo
BlockNo Word64
0

  -- EBB shares its block number with its predecessor.
  expectedNextBlockNo :: forall (proxy :: * -> *).
proxy TestBlock
-> TipInfo TestBlock -> TipInfo TestBlock -> BlockNo -> BlockNo
expectedNextBlockNo proxy TestBlock
_ (TipInfoIsEBB HeaderHash TestBlock
_ IsEBB
prevIsEBB) (TipInfoIsEBB HeaderHash TestBlock
_ IsEBB
curIsEBB) BlockNo
b =
      case (IsEBB
prevIsEBB, IsEBB
curIsEBB) of
        (IsEBB
IsNotEBB, IsEBB
IsEBB) -> BlockNo
b
        (IsEBB, IsEBB)
_otherwise        -> BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
b

instance ValidateEnvelope TestBlock where
  type OtherHeaderEnvelopeError TestBlock = TestBlockOtherHeaderEnvelopeError

  additionalEnvelopeChecks :: TopLevelConfig TestBlock
-> LedgerView (BlockProtocol TestBlock)
-> Header TestBlock
-> Except (OtherHeaderEnvelopeError TestBlock) ()
additionalEnvelopeChecks TopLevelConfig TestBlock
cfg LedgerView (BlockProtocol TestBlock)
_ledgerView Header TestBlock
hdr =
      Bool
-> Except (OtherHeaderEnvelopeError TestBlock) ()
-> Except (OtherHeaderEnvelopeError TestBlock) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsEBB -> Bool
fromIsEBB IsEBB
newIsEBB Bool -> Bool -> Bool
&& Bool -> Bool
not (SlotNo -> Bool
canBeEBB SlotNo
actualSlotNo)) (Except (OtherHeaderEnvelopeError TestBlock) ()
 -> Except (OtherHeaderEnvelopeError TestBlock) ())
-> Except (OtherHeaderEnvelopeError TestBlock) ()
-> Except (OtherHeaderEnvelopeError TestBlock) ()
forall a b. (a -> b) -> a -> b
$
        TestBlockOtherHeaderEnvelopeError
-> Except (OtherHeaderEnvelopeError TestBlock) ()
forall a.
TestBlockOtherHeaderEnvelopeError
-> ExceptT (OtherHeaderEnvelopeError TestBlock) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestBlockOtherHeaderEnvelopeError
 -> Except (OtherHeaderEnvelopeError TestBlock) ())
-> TestBlockOtherHeaderEnvelopeError
-> Except (OtherHeaderEnvelopeError TestBlock) ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TestBlockOtherHeaderEnvelopeError
UnexpectedEBBInSlot SlotNo
actualSlotNo
    where
      actualSlotNo :: SlotNo
      actualSlotNo :: SlotNo
actualSlotNo = Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
hdr

      newIsEBB :: IsEBB
      newIsEBB :: IsEBB
newIsEBB = Header TestBlock -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header TestBlock
hdr

      canBeEBB :: SlotNo -> Bool
      canBeEBB :: SlotNo -> Bool
canBeEBB (SlotNo Word64
s) = BlockConfig TestBlock -> Bool
testBlockEBBsAllowed (TopLevelConfig TestBlock -> BlockConfig TestBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig TestBlock
cfg)
                         Bool -> Bool -> Bool
&& Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
epochSlots Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0

      epochSlots :: Word64
      epochSlots :: Word64
epochSlots =
          EpochSize -> Word64
unEpochSize
        (EpochSize -> Word64)
-> (TopLevelConfig TestBlock -> EpochSize)
-> TopLevelConfig TestBlock
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraParams -> EpochSize
HardFork.eraEpochSize
        (EraParams -> EpochSize)
-> (TopLevelConfig TestBlock -> EraParams)
-> TopLevelConfig TestBlock
-> EpochSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig TestBlock -> LedgerCfg (LedgerState TestBlock)
TopLevelConfig TestBlock -> EraParams
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger
        (TopLevelConfig TestBlock -> Word64)
-> TopLevelConfig TestBlock -> Word64
forall a b. (a -> b) -> a -> b
$ TopLevelConfig TestBlock
cfg

instance LedgerSupportsProtocol TestBlock where
  protocolLedgerView :: LedgerCfg (LedgerState TestBlock)
-> Ticked (LedgerState TestBlock)
-> LedgerView (BlockProtocol TestBlock)
protocolLedgerView   LedgerCfg (LedgerState TestBlock)
_ Ticked (LedgerState TestBlock)
_  = ()
  ledgerViewForecastAt :: HasCallStack =>
LedgerCfg (LedgerState TestBlock)
-> LedgerState TestBlock
-> Forecast (LedgerView (BlockProtocol TestBlock))
ledgerViewForecastAt LedgerCfg (LedgerState TestBlock)
_    = LedgerState TestBlock -> Forecast ()
LedgerState TestBlock
-> Forecast (LedgerView (BlockProtocol TestBlock))
forall b. GetTip b => b -> Forecast ()
trivialForecast

instance HasHardForkHistory TestBlock where
  type HardForkIndices TestBlock = '[TestBlock]
  hardForkSummary :: LedgerCfg (LedgerState TestBlock)
-> LedgerState TestBlock -> Summary (HardForkIndices TestBlock)
hardForkSummary = (LedgerCfg (LedgerState TestBlock) -> EraParams)
-> LedgerCfg (LedgerState TestBlock)
-> LedgerState TestBlock
-> Summary '[TestBlock]
forall blk.
(LedgerConfig blk -> EraParams)
-> LedgerConfig blk -> LedgerState blk -> Summary '[blk]
neverForksHardForkSummary LedgerCfg (LedgerState TestBlock) -> EraParams
EraParams -> EraParams
forall a. a -> a
id

instance InspectLedger TestBlock where
  -- Use defaults

testInitLedger :: LedgerState TestBlock
testInitLedger :: LedgerState TestBlock
testInitLedger = Point TestBlock -> ChainHash TestBlock -> LedgerState TestBlock
TestLedger Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint ChainHash TestBlock
forall {k} (b :: k). ChainHash b
GenesisHash

testInitExtLedger :: ExtLedgerState TestBlock
testInitExtLedger :: ExtLedgerState TestBlock
testInitExtLedger = ExtLedgerState {
      ledgerState :: LedgerState TestBlock
ledgerState = LedgerState TestBlock
testInitLedger
    , headerState :: HeaderState TestBlock
headerState = ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ()
    }

-- Only for a single node
mkTestConfig :: SecurityParam -> ChunkSize -> TopLevelConfig TestBlock
mkTestConfig :: SecurityParam -> ChunkSize -> TopLevelConfig TestBlock
mkTestConfig SecurityParam
k ChunkSize { Bool
chunkCanContainEBB :: Bool
chunkCanContainEBB :: ChunkSize -> Bool
chunkCanContainEBB, Word64
numRegularBlocks :: Word64
numRegularBlocks :: ChunkSize -> Word64
numRegularBlocks } =
    TopLevelConfig {
        topLevelConfigProtocol :: ConsensusConfig (BlockProtocol TestBlock)
topLevelConfigProtocol = ConsensusConfig (Bft BftMockCrypto)
-> ConsensusConfig
     (ModChainSel (Bft BftMockCrypto) BftWithEBBsSelectView)
forall p s. ConsensusConfig p -> ConsensusConfig (ModChainSel p s)
McsConsensusConfig (ConsensusConfig (Bft BftMockCrypto)
 -> ConsensusConfig
      (ModChainSel (Bft BftMockCrypto) BftWithEBBsSelectView))
-> ConsensusConfig (Bft BftMockCrypto)
-> ConsensusConfig
     (ModChainSel (Bft BftMockCrypto) BftWithEBBsSelectView)
forall a b. (a -> b) -> a -> b
$ BftConfig {
            bftParams :: BftParams
bftParams  = BftParams {
                             bftSecurityParam :: SecurityParam
bftSecurityParam = SecurityParam
k
                           , bftNumNodes :: NumCoreNodes
bftNumNodes      = NumCoreNodes
numCoreNodes
                           }
          , bftSignKey :: SignKeyDSIGN (BftDSIGN BftMockCrypto)
bftSignKey = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN Word64
0
          , bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN BftMockCrypto))
bftVerKeys = NodeId
-> VerKeyDSIGN MockDSIGN -> Map NodeId (VerKeyDSIGN MockDSIGN)
forall k a. k -> a -> Map k a
Map.singleton (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
0)) (Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
0)
          }
      , topLevelConfigLedger :: LedgerCfg (LedgerState TestBlock)
topLevelConfigLedger  = LedgerCfg (LedgerState TestBlock)
EraParams
eraParams
      , topLevelConfigBlock :: BlockConfig TestBlock
topLevelConfigBlock   = TestBlockConfig {
            testBlockEBBsAllowed :: Bool
testBlockEBBsAllowed  = Bool
chunkCanContainEBB
          , testBlockNumCoreNodes :: NumCoreNodes
testBlockNumCoreNodes = NumCoreNodes
numCoreNodes
          }
      , topLevelConfigCodec :: CodecConfig TestBlock
topLevelConfigCodec       = CodecConfig TestBlock
TestBlockCodecConfig
      , topLevelConfigStorage :: StorageConfig TestBlock
topLevelConfigStorage     = StorageConfig TestBlock
TestBlockStorageConfig
      , topLevelConfigCheckpoints :: CheckpointsMap TestBlock
topLevelConfigCheckpoints = CheckpointsMap TestBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
      }
  where
    slotLength :: SlotLength
    slotLength :: SlotLength
slotLength = Integer -> SlotLength
slotLengthFromSec Integer
20

    numCoreNodes :: NumCoreNodes
    numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
1

    eraParams :: HardFork.EraParams
    eraParams :: EraParams
eraParams = HardFork.EraParams {
        eraEpochSize :: EpochSize
eraEpochSize  = Word64 -> EpochSize
EpochSize Word64
numRegularBlocks
      , eraSlotLength :: SlotLength
eraSlotLength = SlotLength
slotLength
      , eraSafeZone :: SafeZone
eraSafeZone   = Word64 -> SafeZone
HardFork.StandardSafeZone (SecurityParam -> Word64
maxRollbacks SecurityParam
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2)
      , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow (SecurityParam -> Word64
maxRollbacks SecurityParam
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2)
      }

{-------------------------------------------------------------------------------
  NestedCtxt
-------------------------------------------------------------------------------}

data instance NestedCtxt_ TestBlock f a where
  CtxtTestBlock :: NestedCtxt_ TestBlock f (f TestBlock)

deriving instance Show (NestedCtxt_ TestBlock f a)

instance TrivialDependency (NestedCtxt_ TestBlock f) where
  type TrivialIndex (NestedCtxt_ TestBlock f) = f TestBlock
  hasSingleIndex :: forall a b.
NestedCtxt_ TestBlock f a -> NestedCtxt_ TestBlock f b -> a :~: b
hasSingleIndex NestedCtxt_ TestBlock f a
R:NestedCtxt_TestBlockfa f a
CtxtTestBlock NestedCtxt_ TestBlock f b
R:NestedCtxt_TestBlockfa f b
CtxtTestBlock = a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  indexIsTrivial :: NestedCtxt_ TestBlock f (TrivialIndex (NestedCtxt_ TestBlock f))
indexIsTrivial = NestedCtxt_ TestBlock f (f TestBlock)
NestedCtxt_ TestBlock f (TrivialIndex (NestedCtxt_ TestBlock f))
forall (f :: * -> *). NestedCtxt_ TestBlock f (f TestBlock)
CtxtTestBlock

instance SameDepIndex (NestedCtxt_ TestBlock f)
instance HasNestedContent f TestBlock

{-------------------------------------------------------------------------------
  Test infrastructure: serialisation
-------------------------------------------------------------------------------}

instance HasBinaryBlockInfo TestBlock where
  getBinaryBlockInfo :: TestBlock -> BinaryBlockInfo
getBinaryBlockInfo TestBlock
tb = BinaryBlockInfo
      { headerOffset :: Word16
headerOffset = Word16
testBlockHeaderOffset
      , headerSize :: Word16
headerSize   = TestBlock -> Word16
testBlockHeaderSize TestBlock
tb
      }

instance SerialiseDiskConstraints TestBlock

instance EncodeDisk TestBlock TestBlock
instance DecodeDisk TestBlock (Lazy.ByteString -> TestBlock) where
  decodeDisk :: CodecConfig TestBlock
-> forall s. Decoder s (ByteString -> TestBlock)
decodeDisk CodecConfig TestBlock
_ = TestBlock -> ByteString -> TestBlock
forall a b. a -> b -> a
const (TestBlock -> ByteString -> TestBlock)
-> Decoder s TestBlock -> Decoder s (ByteString -> TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s TestBlock
forall s. Decoder s TestBlock
forall a s. Serialise a => Decoder s a
decode

instance EncodeDisk TestBlock (Header TestBlock)
instance DecodeDisk TestBlock (Lazy.ByteString -> Header TestBlock) where
  decodeDisk :: CodecConfig TestBlock
-> forall s. Decoder s (ByteString -> Header TestBlock)
decodeDisk CodecConfig TestBlock
_ = Header TestBlock -> ByteString -> Header TestBlock
forall a b. a -> b -> a
const (Header TestBlock -> ByteString -> Header TestBlock)
-> Decoder s (Header TestBlock)
-> Decoder s (ByteString -> Header TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Header TestBlock)
forall s. Decoder s (Header TestBlock)
forall a s. Serialise a => Decoder s a
decode

instance EncodeDisk TestBlock (LedgerState TestBlock)
instance DecodeDisk TestBlock (LedgerState TestBlock)

instance EncodeDisk TestBlock (AnnTip TestBlock) where
  encodeDisk :: CodecConfig TestBlock -> AnnTip TestBlock -> Encoding
encodeDisk CodecConfig TestBlock
_ = (HeaderHash TestBlock -> Encoding) -> AnnTip TestBlock -> Encoding
forall blk.
(TipInfo blk ~ TipInfoIsEBB blk) =>
(HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
encodeAnnTipIsEBB HeaderHash TestBlock -> Encoding
TestHeaderHash -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance DecodeDisk TestBlock (AnnTip TestBlock) where
  decodeDisk :: CodecConfig TestBlock -> forall s. Decoder s (AnnTip TestBlock)
decodeDisk CodecConfig TestBlock
_ = (forall s. Decoder s (HeaderHash TestBlock))
-> forall s. Decoder s (AnnTip TestBlock)
forall blk.
(TipInfo blk ~ TipInfoIsEBB blk) =>
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
decodeAnnTipIsEBB Decoder s (HeaderHash TestBlock)
Decoder s TestHeaderHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHeaderHash
forall a s. Serialise a => Decoder s a
decode

instance ReconstructNestedCtxt       Header  TestBlock
instance EncodeDiskDepIx (NestedCtxt Header) TestBlock
instance EncodeDiskDep   (NestedCtxt Header) TestBlock
instance DecodeDiskDepIx (NestedCtxt Header) TestBlock
instance DecodeDiskDep   (NestedCtxt Header) TestBlock

-- ChainDepState
instance EncodeDisk TestBlock ()
instance DecodeDisk TestBlock ()

{-------------------------------------------------------------------------------
  Additional instances
-------------------------------------------------------------------------------}

deriving via SelectViewDiffusionPipelining TestBlock
  instance BlockSupportsDiffusionPipelining TestBlock

{-------------------------------------------------------------------------------
  Corruption
-------------------------------------------------------------------------------}

data FileCorruption
  = DeleteFile
  | DropLastBytes Word64
    -- ^ Drop the last @n@ bytes of a file.
  | Corrupt Word64
    -- ^ Corrupt the file by adding 1 to the byte at the given location
    -- (modulo the file size).
  deriving (Int -> FileCorruption -> ShowS
[FileCorruption] -> ShowS
FileCorruption -> String
(Int -> FileCorruption -> ShowS)
-> (FileCorruption -> String)
-> ([FileCorruption] -> ShowS)
-> Show FileCorruption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileCorruption -> ShowS
showsPrec :: Int -> FileCorruption -> ShowS
$cshow :: FileCorruption -> String
show :: FileCorruption -> String
$cshowList :: [FileCorruption] -> ShowS
showList :: [FileCorruption] -> ShowS
Show, FileCorruption -> FileCorruption -> Bool
(FileCorruption -> FileCorruption -> Bool)
-> (FileCorruption -> FileCorruption -> Bool) -> Eq FileCorruption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileCorruption -> FileCorruption -> Bool
== :: FileCorruption -> FileCorruption -> Bool
$c/= :: FileCorruption -> FileCorruption -> Bool
/= :: FileCorruption -> FileCorruption -> Bool
Eq)

-- | Returns 'True' when something was actually corrupted. For example, when
-- drop the last bytes of an empty file, we don't actually corrupt it.
corruptFile :: MonadThrow m => HasFS m h -> FileCorruption -> FsPath -> m Bool
corruptFile :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> FileCorruption -> FsPath -> m Bool
corruptFile hasFS :: HasFS m h
hasFS@HasFS{m String
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => Handle h -> m Bool
HasCallStack => Handle h -> m Word64
HasCallStack => Handle h -> m ()
HasCallStack => Handle h -> Word64 -> m ()
HasCallStack => Handle h -> Word64 -> m ByteString
HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle h -> ByteString -> m Word64
HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> m String
FsPath -> FsErrorPath
dumpState :: m String
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
hClose :: HasCallStack => Handle h -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
createDirectory :: HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
listDirectory :: HasCallStack => FsPath -> m (Set String)
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesFileExist :: HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m String
hGetBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
..} FileCorruption
fc FsPath
file = case FileCorruption
fc of
    FileCorruption
DeleteFile              -> HasCallStack => FsPath -> m ()
FsPath -> m ()
removeFile FsPath
file m () -> Bool -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
    DropLastBytes Word64
n         -> HasFS m h -> FsPath -> OpenMode -> (Handle h -> m Bool) -> m Bool
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
file (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting) ((Handle h -> m Bool) -> m Bool) -> (Handle h -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \Handle h
hnd -> do
      Word64
fileSize <- HasCallStack => Handle h -> m Word64
Handle h -> m Word64
hGetSize Handle h
hnd
      let newFileSize :: Word64
newFileSize = if Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
fileSize then Word64
0 else Word64
fileSize Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
n
      HasCallStack => Handle h -> Word64 -> m ()
Handle h -> Word64 -> m ()
hTruncate Handle h
hnd Word64
newFileSize
      Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Word64
fileSize Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
newFileSize
    Corrupt Word64
n               -> HasFS m h -> FsPath -> OpenMode -> (Handle h -> m Bool) -> m Bool
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
file (AllowExisting -> OpenMode
ReadWriteMode AllowExisting
AllowExisting) ((Handle h -> m Bool) -> m Bool) -> (Handle h -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \Handle h
hnd -> do
      Word64
fileSize <- HasCallStack => Handle h -> m Word64
Handle h -> m Word64
hGetSize Handle h
hnd
      if Word64
fileSize Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 then
        Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else do
        let offset :: Int64
            offset :: Int64
offset = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
fileSize
        HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
Handle h -> SeekMode -> Int64 -> m ()
hSeek Handle h
hnd SeekMode
AbsoluteSeek Int64
offset
        ByteString
bs <- HasFS m h -> Handle h -> Word64 -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> m ByteString
hGetExactly HasFS m h
hasFS Handle h
hnd Word64
1
        HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
Handle h -> SeekMode -> Int64 -> m ()
hSeek Handle h
hnd SeekMode
RelativeSeek (-Int64
1)
        Word64
_ <- HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
hasFS Handle h
hnd ((Word8 -> Word8) -> ByteString -> ByteString
Lazy.map (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1) ByteString
bs)
        Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


instance Arbitrary FileCorruption where
  arbitrary :: Gen FileCorruption
arbitrary = [(Int, Gen FileCorruption)] -> Gen FileCorruption
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, FileCorruption -> Gen FileCorruption
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return FileCorruption
DeleteFile)
    , (Int
1, Word64 -> FileCorruption
DropLastBytes (Word64 -> FileCorruption)
-> (Positive (Small Word64) -> Word64)
-> Positive (Small Word64)
-> FileCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Small Word64 -> Word64
forall a. Small a -> a
getSmall (Small Word64 -> Word64)
-> (Positive (Small Word64) -> Small Word64)
-> Positive (Small Word64)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive (Small Word64) -> Small Word64
forall a. Positive a -> a
getPositive (Positive (Small Word64) -> FileCorruption)
-> Gen (Positive (Small Word64)) -> Gen FileCorruption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive (Small Word64))
forall a. Arbitrary a => Gen a
arbitrary)
    , (Int
1, Word64 -> FileCorruption
Corrupt (Word64 -> FileCorruption)
-> (Positive (Small Word64) -> Word64)
-> Positive (Small Word64)
-> FileCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Small Word64 -> Word64
forall a. Small a -> a
getSmall (Small Word64 -> Word64)
-> (Positive (Small Word64) -> Small Word64)
-> Positive (Small Word64)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive (Small Word64) -> Small Word64
forall a. Positive a -> a
getPositive (Positive (Small Word64) -> FileCorruption)
-> Gen (Positive (Small Word64)) -> Gen FileCorruption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive (Small Word64))
forall a. Arbitrary a => Gen a
arbitrary)
    ]
  shrink :: FileCorruption -> [FileCorruption]
shrink FileCorruption
DeleteFile         = []
  shrink (DropLastBytes Word64
n)  =
    Word64 -> FileCorruption
DropLastBytes (Word64 -> FileCorruption)
-> (Positive (Small Word64) -> Word64)
-> Positive (Small Word64)
-> FileCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Small Word64 -> Word64
forall a. Small a -> a
getSmall (Small Word64 -> Word64)
-> (Positive (Small Word64) -> Small Word64)
-> Positive (Small Word64)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive (Small Word64) -> Small Word64
forall a. Positive a -> a
getPositive (Positive (Small Word64) -> FileCorruption)
-> [Positive (Small Word64)] -> [FileCorruption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Positive (Small Word64) -> [Positive (Small Word64)]
forall a. Arbitrary a => a -> [a]
shrink (Small Word64 -> Positive (Small Word64)
forall a. a -> Positive a
Positive (Word64 -> Small Word64
forall a. a -> Small a
Small Word64
n))
  shrink (Corrupt Word64
n) =
    Word64 -> FileCorruption
Corrupt (Word64 -> FileCorruption)
-> (Positive (Small Word64) -> Word64)
-> Positive (Small Word64)
-> FileCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Small Word64 -> Word64
forall a. Small a -> a
getSmall (Small Word64 -> Word64)
-> (Positive (Small Word64) -> Small Word64)
-> Positive (Small Word64)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive (Small Word64) -> Small Word64
forall a. Positive a -> a
getPositive (Positive (Small Word64) -> FileCorruption)
-> [Positive (Small Word64)] -> [FileCorruption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Positive (Small Word64) -> [Positive (Small Word64)]
forall a. Arbitrary a => a -> [a]
shrink (Small Word64 -> Positive (Small Word64)
forall a. a -> Positive a
Positive (Word64 -> Small Word64
forall a. a -> Small a
Small Word64
n))

-- | Multiple corruptions
type Corruptions = NonEmpty (FileCorruption, FsPath)

-- | The same file will not occur twice.
generateCorruptions :: NonEmpty FsPath -> Gen Corruptions
generateCorruptions :: NonEmpty FsPath -> Gen Corruptions
generateCorruptions NonEmpty FsPath
allFiles = (Int -> Gen Corruptions) -> Gen Corruptions
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Corruptions) -> Gen Corruptions)
-> (Int -> Gen Corruptions) -> Gen Corruptions
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
    [FsPath]
subl  <- [FsPath] -> Gen [FsPath]
forall a. [a] -> Gen [a]
sublistOf (NonEmpty FsPath -> [FsPath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FsPath
allFiles) Gen [FsPath] -> ([FsPath] -> Bool) -> Gen [FsPath]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool) -> ([FsPath] -> Bool) -> [FsPath] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FsPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
    Int
k     <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
1 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
n)
    let files :: NonEmpty FsPath
files = [FsPath] -> NonEmpty FsPath
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([FsPath] -> NonEmpty FsPath) -> [FsPath] -> NonEmpty FsPath
forall a b. (a -> b) -> a -> b
$ Int -> [FsPath] -> [FsPath]
forall a. Int -> [a] -> [a]
take Int
k [FsPath]
subl
    NonEmpty FsPath
-> (FsPath -> Gen (FileCorruption, FsPath)) -> Gen Corruptions
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty FsPath
files ((FsPath -> Gen (FileCorruption, FsPath)) -> Gen Corruptions)
-> (FsPath -> Gen (FileCorruption, FsPath)) -> Gen Corruptions
forall a b. (a -> b) -> a -> b
$ \FsPath
file -> (, FsPath
file) (FileCorruption -> (FileCorruption, FsPath))
-> Gen FileCorruption -> Gen (FileCorruption, FsPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen FileCorruption
forall a. Arbitrary a => Gen a
arbitrary

shrinkCorruptions :: Corruptions -> [Corruptions]
shrinkCorruptions :: Corruptions -> [Corruptions]
shrinkCorruptions Corruptions
cs =
    [ Corruptions
cs''
    | [(FileCorruption, FsPath)]
cs'  <- ((FileCorruption, FsPath) -> [(FileCorruption, FsPath)])
-> [(FileCorruption, FsPath)] -> [[(FileCorruption, FsPath)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (FileCorruption, FsPath) -> [(FileCorruption, FsPath)]
shrinkCor (Corruptions -> [(FileCorruption, FsPath)]
forall a. NonEmpty a -> [a]
NE.toList Corruptions
cs)
    , Corruptions
cs'' <- Maybe Corruptions -> [Corruptions]
forall a. Maybe a -> [a]
maybeToList (Maybe Corruptions -> [Corruptions])
-> Maybe Corruptions -> [Corruptions]
forall a b. (a -> b) -> a -> b
$ [(FileCorruption, FsPath)] -> Maybe Corruptions
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(FileCorruption, FsPath)]
cs'
    ]
  where
    shrinkCor :: (FileCorruption, FsPath) -> [(FileCorruption, FsPath)]
    shrinkCor :: (FileCorruption, FsPath) -> [(FileCorruption, FsPath)]
shrinkCor (FileCorruption
c, FsPath
f) = [(FileCorruption
c', FsPath
f) | FileCorruption
c' <- FileCorruption -> [FileCorruption]
forall a. Arbitrary a => a -> [a]
shrink FileCorruption
c]

-- | Return a list of all files that will be corrupted
corruptionFiles :: Corruptions -> [FsPath]
corruptionFiles :: Corruptions -> [FsPath]
corruptionFiles = ((FileCorruption, FsPath) -> FsPath)
-> [(FileCorruption, FsPath)] -> [FsPath]
forall a b. (a -> b) -> [a] -> [b]
map (FileCorruption, FsPath) -> FsPath
forall a b. (a, b) -> b
snd ([(FileCorruption, FsPath)] -> [FsPath])
-> (Corruptions -> [(FileCorruption, FsPath)])
-> Corruptions
-> [FsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Corruptions -> [(FileCorruption, FsPath)]
forall a. NonEmpty a -> [a]
NE.toList

{-------------------------------------------------------------------------------
  Orphans
-------------------------------------------------------------------------------}

deriving newtype instance Hashable SlotNo
deriving newtype instance Hashable BlockNo
instance Hashable IsEBB
  -- use generic instance

instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b)
  -- use generic instance

instance ToExpr EBB
instance ToExpr IsEBB
instance ToExpr ChainLength
instance ToExpr TestHeaderHash
instance ToExpr TestBodyHash
instance ToExpr TestHeader
instance ToExpr TestBody
instance ToExpr TestBlock
instance ToExpr (CodecConfig TestBlock)
instance ToExpr (Tip TestBlock)


deriving instance ToExpr TestBlockError
deriving instance ToExpr (TipInfoIsEBB TestBlock)
deriving instance ToExpr (LedgerState TestBlock)
deriving instance ToExpr (HeaderError TestBlock)
deriving instance ToExpr TestBlockOtherHeaderEnvelopeError
deriving instance ToExpr (HeaderEnvelopeError TestBlock)
deriving instance ToExpr BftValidationErr
deriving instance ToExpr (ExtValidationError TestBlock)

instance ModelSupportsBlock TestBlock

deriving anyclass instance ToExpr FsPath
deriving anyclass instance ToExpr BlocksPerFile
deriving instance ToExpr BinaryBlockInfo