{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Chain.Block.Validation (
  UPI.adoptedProtocolParameters,
  updateBody,
  updateChainBlockOrBoundary,
  updateChainBoundary,
  epochTransition,
  headerIsValid,
  validateHeaderMatchesBody,
  updateBlock,
  BodyState (..),
  BodyEnvironment (..),
  EpochEnvironment (..),
  ChainValidationState (..),
  initialChainValidationState,
  ChainValidationError (..),

  -- * UTxO
  HeapSize (..),
  UTxOSize (..),
  calcUTxOSize,
  foldUTxO,
  foldUTxOBlock,
)
where

import Cardano.Chain.Block.Block (
  ABlock (..),
  ABlockOrBoundary (..),
  ABoundaryBlock (..),
  blockAProtocolMagicId,
  blockDlgPayload,
  blockHashAnnotated,
  blockHeader,
  blockIssuer,
  blockLength,
  blockProtocolMagicId,
  blockProtocolVersion,
  blockSlot,
  blockTxPayload,
  blockUpdatePayload,
 )
import Cardano.Chain.Block.Body (ABody (..))
import Cardano.Chain.Block.Header (
  ABoundaryHeader (..),
  AHeader (..),
  BlockSignature,
  HeaderHash,
  headerLength,
  headerProof,
  wrapBoundaryBytes,
 )
import Cardano.Chain.Block.Proof (Proof (..), ProofValidationError (..))
import Cardano.Chain.Common (
  BlockCount (..),
  KeyHash,
  hashKey,
 )
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Delegation.Validation.Interface as DI
import qualified Cardano.Chain.Delegation.Validation.Scheduling as Scheduling
import Cardano.Chain.Epoch.File (ParseError, mainnetEpochSlots)
import Cardano.Chain.Genesis as Genesis (
  Config (..),
  GenesisHash,
  GenesisKeyHashes (..),
  configEpochSlots,
  configGenesisKeyHashes,
  configHeavyDelegation,
  configK,
  configProtocolMagicId,
 )
import Cardano.Chain.ProtocolConstants (kEpochSlots)
import Cardano.Chain.Slotting (
  EpochAndSlotCount (..),
  EpochNumber (..),
  SlotNumber (..),
  fromSlotNumber,
  slotNumberEpoch,
 )
import Cardano.Chain.UTxO (ATxPayload (..), UTxO (..), genesisUtxo, recoverTxProof)
import Cardano.Chain.UTxO.UTxOConfiguration (UTxOConfiguration)
import qualified Cardano.Chain.UTxO.Validation as UTxO
import qualified Cardano.Chain.Update as Update
import Cardano.Chain.Update.Validation.Endorsement (Endorsement (..))
import qualified Cardano.Chain.Update.Validation.Interface as UPI
import Cardano.Chain.ValidationMode (
  ValidationMode,
  orThrowErrorInBlockValidationMode,
  whenBlockValidation,
  wrapErrorWithValidationMode,
 )
import Cardano.Crypto (
  AProtocolMagic (..),
  ProtocolMagicId,
  VerificationKey,
  hashDecoded,
  hashRaw,
 )
import Cardano.HeapWords (HeapWords (..))
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  byronProtVer,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  serialize',
  toByronCBOR,
 )
import Cardano.Prelude
import Control.Monad.Trans.Resource (ResIO)
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import Formatting.Buildable (Buildable)
import NoThunks.Class (NoThunks (..))
import Streaming (Of (..), Stream, hoist)
import qualified Streaming.Prelude as S

--------------------------------------------------------------------------------
-- ChainValidationState
--------------------------------------------------------------------------------

data ChainValidationState = ChainValidationState
  { ChainValidationState -> SlotNumber
cvsLastSlot :: !SlotNumber
  , ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash :: !(Either GenesisHash HeaderHash)
  -- ^ GenesisHash for the previous hash of the zeroth boundary block and
  --   HeaderHash for all others.
  , ChainValidationState -> UTxO
cvsUtxo :: !UTxO
  , ChainValidationState -> State
cvsUpdateState :: !UPI.State
  , ChainValidationState -> State
cvsDelegationState :: !DI.State
  }
  deriving (ChainValidationState -> ChainValidationState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainValidationState -> ChainValidationState -> Bool
$c/= :: ChainValidationState -> ChainValidationState -> Bool
== :: ChainValidationState -> ChainValidationState -> Bool
$c== :: ChainValidationState -> ChainValidationState -> Bool
Eq, Int -> ChainValidationState -> ShowS
[ChainValidationState] -> ShowS
ChainValidationState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainValidationState] -> ShowS
$cshowList :: [ChainValidationState] -> ShowS
show :: ChainValidationState -> String
$cshow :: ChainValidationState -> String
showsPrec :: Int -> ChainValidationState -> ShowS
$cshowsPrec :: Int -> ChainValidationState -> ShowS
Show, forall x. Rep ChainValidationState x -> ChainValidationState
forall x. ChainValidationState -> Rep ChainValidationState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainValidationState x -> ChainValidationState
$cfrom :: forall x. ChainValidationState -> Rep ChainValidationState x
Generic, ChainValidationState -> ()
forall a. (a -> ()) -> NFData a
rnf :: ChainValidationState -> ()
$crnf :: ChainValidationState -> ()
NFData, Context -> ChainValidationState -> IO (Maybe ThunkInfo)
Proxy ChainValidationState -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ChainValidationState -> String
$cshowTypeOf :: Proxy ChainValidationState -> String
wNoThunks :: Context -> ChainValidationState -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainValidationState -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainValidationState -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ChainValidationState -> IO (Maybe ThunkInfo)
NoThunks)

instance ToCBOR ChainValidationState where
  toCBOR :: ChainValidationState -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR ChainValidationState where
  fromCBOR :: forall s. Decoder s ChainValidationState
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance DecCBOR ChainValidationState where
  decCBOR :: forall s. Decoder s ChainValidationState
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ChainValidationState" Int
5
    SlotNumber
-> Either GenesisHash HeaderHash
-> UTxO
-> State
-> State
-> ChainValidationState
ChainValidationState
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR

instance EncCBOR ChainValidationState where
  encCBOR :: ChainValidationState -> Encoding
encCBOR ChainValidationState
c =
    Word -> Encoding
encodeListLen Word
5
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ChainValidationState -> SlotNumber
cvsLastSlot ChainValidationState
c)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash ChainValidationState
c)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ChainValidationState -> UTxO
cvsUtxo ChainValidationState
c)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ChainValidationState -> State
cvsUpdateState ChainValidationState
c)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ChainValidationState -> State
cvsDelegationState ChainValidationState
c)

-- | Create the state needed to validate the zeroth epoch of the chain. The
--   zeroth epoch starts with a boundary block where the previous hash is the
--   genesis hash.
initialChainValidationState ::
  MonadError Scheduling.Error m =>
  Genesis.Config ->
  m ChainValidationState
initialChainValidationState :: forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config = do
  State
delegationState <- forall (m :: * -> *).
MonadError Error m =>
Environment -> GenesisDelegation -> m State
DI.initialState Environment
delegationEnv GenesisDelegation
genesisDelegation
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ ChainValidationState
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
cvsLastSlot = SlotNumber
0
      , -- Ensure that we don't allow the internal value of this 'Left' to be
        -- lazy as we want to ensure that the 'ChainValidationState' is always
        -- in normal form.
        $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
cvsPreviousHash = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$! Config -> GenesisHash
configGenesisHash Config
config
      , $sel:cvsUtxo:ChainValidationState :: UTxO
cvsUtxo = Config -> UTxO
genesisUtxo Config
config
      , $sel:cvsUpdateState:ChainValidationState :: State
cvsUpdateState = Config -> State
UPI.initialState Config
config
      , $sel:cvsDelegationState:ChainValidationState :: State
cvsDelegationState = State
delegationState
      }
  where
    delegationEnv :: Environment
delegationEnv =
      DI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
DI.protocolMagic = forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pm (forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer ProtocolMagicId
pm)
        , allowedDelegators :: Set KeyHash
DI.allowedDelegators = GenesisKeyHashes -> Set KeyHash
unGenesisKeyHashes forall a b. (a -> b) -> a -> b
$ Config -> GenesisKeyHashes
configGenesisKeyHashes Config
config
        , k :: BlockCount
DI.k = Config -> BlockCount
configK Config
config
        , currentEpoch :: EpochNumber
DI.currentEpoch = Word64 -> EpochNumber
EpochNumber Word64
0
        , currentSlot :: SlotNumber
DI.currentSlot = Word64 -> SlotNumber
SlotNumber Word64
0
        }

    pm :: ProtocolMagicId
pm = Config -> ProtocolMagicId
configProtocolMagicId Config
config

    genesisDelegation :: GenesisDelegation
genesisDelegation = Config -> GenesisDelegation
configHeavyDelegation Config
config

--------------------------------------------------------------------------------
-- ChainValidationError
--------------------------------------------------------------------------------

data ChainValidationError
  = -- | The size of an epoch boundary block exceeds the limit
    ChainValidationBoundaryTooLarge
  | -- | The size of a block's attributes is non-zero
    ChainValidationBlockAttributesTooLarge
  | -- | The size of a regular block exceeds the limit
    ChainValidationBlockTooLarge Natural Natural
  | -- | The size of a block header's attributes is non-zero
    ChainValidationHeaderAttributesTooLarge
  | -- | The size of a block header exceeds the limit
    ChainValidationHeaderTooLarge Natural Natural
  | -- | There is a problem with the delegation payload signature
    ChainValidationDelegationPayloadError Text
  | -- | The delegation used in the signature is not valid according to the ledger
    ChainValidationInvalidDelegation VerificationKey VerificationKey
  | -- | Genesis hash mismatch
    ChainValidationGenesisHashMismatch GenesisHash GenesisHash
  | -- | Expected GenesisHash but got HeaderHash
    ChainValidationExpectedGenesisHash GenesisHash HeaderHash
  | -- | Expected HeaderHash but GenesisHash
    ChainValidationExpectedHeaderHash HeaderHash GenesisHash
  | -- | The hash of the previous block does not match the value in the header
    ChainValidationInvalidHash HeaderHash HeaderHash
  | -- | The hash of the previous block is missing and should be given hash.
    ChainValidationMissingHash HeaderHash
  | -- | There should not be a hash of the previous but there is.
    ChainValidationUnexpectedGenesisHash HeaderHash
  | -- | The signature of the block is invalid
    ChainValidationInvalidSignature BlockSignature
  | -- | A delegation certificate failed validation in the ledger layer
    ChainValidationDelegationSchedulingError Scheduling.Error
  | -- | The 'ProtocolMagic' in the block doesn't match the configured one
    ChainValidationProtocolMagicMismatch ProtocolMagicId ProtocolMagicId
  | -- | A block is using unsupported lightweight delegation
    ChainValidationSignatureLight
  | -- | The delegator for this block has delegated in too many recent blocks
    ChainValidationTooManyDelegations VerificationKey
  | -- | Something failed to register in the update interface
    ChainValidationUpdateError SlotNumber UPI.Error
  | -- | A transaction failed validation in the ledger layer
    ChainValidationUTxOValidationError UTxO.UTxOValidationError
  | -- | A payload proof did not match.
    ChainValidationProofValidationError ProofValidationError
  deriving (ChainValidationError -> ChainValidationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainValidationError -> ChainValidationError -> Bool
$c/= :: ChainValidationError -> ChainValidationError -> Bool
== :: ChainValidationError -> ChainValidationError -> Bool
$c== :: ChainValidationError -> ChainValidationError -> Bool
Eq, Int -> ChainValidationError -> ShowS
[ChainValidationError] -> ShowS
ChainValidationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainValidationError] -> ShowS
$cshowList :: [ChainValidationError] -> ShowS
show :: ChainValidationError -> String
$cshow :: ChainValidationError -> String
showsPrec :: Int -> ChainValidationError -> ShowS
$cshowsPrec :: Int -> ChainValidationError -> ShowS
Show)

--------------------------------------------------------------------------------
-- Validation Functions
--------------------------------------------------------------------------------

updateChainBlockOrBoundary ::
  (MonadError ChainValidationError m, MonadReader ValidationMode m) =>
  Genesis.Config ->
  ChainValidationState ->
  ABlockOrBoundary ByteString ->
  m ChainValidationState
updateChainBlockOrBoundary :: forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> m ChainValidationState
updateChainBlockOrBoundary Config
config ChainValidationState
c ABlockOrBoundary ByteString
b = case ABlockOrBoundary ByteString
b of
  ABOBBoundary ABoundaryBlock ByteString
bvd -> forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
c ABoundaryBlock ByteString
bvd
  ABOBBlock ABlock ByteString
block -> forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
c ABlock ByteString
block

updateChainBoundary ::
  MonadError ChainValidationError m =>
  ChainValidationState ->
  ABoundaryBlock ByteString ->
  m ChainValidationState
updateChainBoundary :: forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
cvs ABoundaryBlock ByteString
bvd = do
  case (ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash ChainValidationState
cvs, forall a. ABoundaryHeader a -> Either GenesisHash HeaderHash
boundaryPrevHash (forall a. ABoundaryBlock a -> ABoundaryHeader a
boundaryHeader ABoundaryBlock ByteString
bvd)) of
    (Left GenesisHash
expected, Left GenesisHash
actual) ->
      (GenesisHash
expected forall a. Eq a => a -> a -> Bool
== GenesisHash
actual)
        forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` GenesisHash -> GenesisHash -> ChainValidationError
ChainValidationGenesisHashMismatch GenesisHash
expected GenesisHash
actual
    (Right HeaderHash
expected, Right HeaderHash
actual) ->
      (HeaderHash
expected forall a. Eq a => a -> a -> Bool
== HeaderHash
actual)
        forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` HeaderHash -> HeaderHash -> ChainValidationError
ChainValidationInvalidHash HeaderHash
expected HeaderHash
actual
    (Left GenesisHash
gh, Right HeaderHash
hh) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ GenesisHash -> HeaderHash -> ChainValidationError
ChainValidationExpectedGenesisHash GenesisHash
gh HeaderHash
hh
    (Right HeaderHash
hh, Left GenesisHash
gh) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ HeaderHash -> GenesisHash -> ChainValidationError
ChainValidationExpectedHeaderHash HeaderHash
hh GenesisHash
gh

  -- Validate that the block is within the size bounds
  (forall a. ABoundaryBlock a -> Int64
boundaryBlockLength ABoundaryBlock ByteString
bvd forall a. Ord a => a -> a -> Bool
<= Int64
2e6)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ChainValidationError
ChainValidationBoundaryTooLarge

  -- Update the previous hash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      { $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
cvsPreviousHash = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! HeaderHash
previousHash
      }
  where
    previousHash :: HeaderHash
    previousHash :: HeaderHash
previousHash =
      coerce :: forall a b. Coercible a b => a -> b
coerce
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Hash Raw
hashRaw
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
BSL.fromStrict
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
wrapBoundaryBytes
        forall a b. (a -> b) -> a -> b
$ forall a. ABoundaryHeader a -> a
boundaryHeaderAnnotation (forall a. ABoundaryBlock a -> ABoundaryHeader a
boundaryHeader ABoundaryBlock ByteString
bvd)

validateHeaderMatchesBody ::
  MonadError ProofValidationError m =>
  AHeader ByteString ->
  ABody ByteString ->
  m ()
validateHeaderMatchesBody :: forall (m :: * -> *).
MonadError ProofValidationError m =>
AHeader ByteString -> ABody ByteString -> m ()
validateHeaderMatchesBody AHeader ByteString
hdr ABody ByteString
body = do
  let hdrProof :: Proof
hdrProof = forall a. AHeader a -> Proof
headerProof AHeader ByteString
hdr

  -- Validate the delegation payload signature
  Proof -> Hash Payload
proofDelegation Proof
hdrProof
    forall a. Eq a => a -> a -> Bool
== forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (forall a. ABody a -> APayload a
bodyDlgPayload ABody ByteString
body)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ProofValidationError
DelegationProofValidationError

  -- Validate the transaction payload proof
  Proof -> TxProof
proofUTxO Proof
hdrProof
    forall a. Eq a => a -> a -> Bool
== ATxPayload ByteString -> TxProof
recoverTxProof (forall a. ABody a -> ATxPayload a
bodyTxPayload ABody ByteString
body)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ProofValidationError
UTxOProofValidationError

  -- Validate the update payload proof
  Proof -> Proof
proofUpdate Proof
hdrProof
    forall a. Eq a => a -> a -> Bool
== forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (forall a. ABody a -> APayload a
bodyUpdatePayload ABody ByteString
body)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ProofValidationError
UpdateProofValidationError

validateBlockProofs ::
  MonadError ProofValidationError m =>
  ABlock ByteString ->
  m ()
validateBlockProofs :: forall (m :: * -> *).
MonadError ProofValidationError m =>
ABlock ByteString -> m ()
validateBlockProofs ABlock ByteString
b =
  forall (m :: * -> *).
MonadError ProofValidationError m =>
AHeader ByteString -> ABody ByteString -> m ()
validateHeaderMatchesBody AHeader ByteString
blockHeader ABody ByteString
blockBody
  where
    ABlock
      { AHeader ByteString
blockHeader :: AHeader ByteString
blockHeader :: forall a. ABlock a -> AHeader a
blockHeader
      , ABody ByteString
blockBody :: forall a. ABlock a -> ABody a
blockBody :: ABody ByteString
blockBody
      } = ABlock ByteString
b

data BodyEnvironment = BodyEnvironment
  { BodyEnvironment -> AProtocolMagic ByteString
protocolMagic :: !(AProtocolMagic ByteString)
  , BodyEnvironment -> UTxOConfiguration
utxoConfiguration :: !UTxOConfiguration
  , BodyEnvironment -> BlockCount
k :: !BlockCount
  , BodyEnvironment -> Set KeyHash
allowedDelegators :: !(Set KeyHash)
  , BodyEnvironment -> ProtocolParameters
protocolParameters :: !Update.ProtocolParameters
  , BodyEnvironment -> EpochNumber
currentEpoch :: !EpochNumber
  }

data BodyState = BodyState
  { BodyState -> UTxO
utxo :: !UTxO
  , BodyState -> State
updateState :: !UPI.State
  , BodyState -> State
delegationState :: !DI.State
  }

-- | This is an implementation of the BBODY rule as per the chain specification.
--
--   Compared to `updateChain`, this does not validate any header level checks,
--   nor does it carry out anything which might be considered part of the
--   protocol.
updateBody ::
  (MonadError ChainValidationError m, MonadReader ValidationMode m) =>
  BodyEnvironment ->
  BodyState ->
  ABlock ByteString ->
  m BodyState
updateBody :: forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
BodyEnvironment -> BodyState -> ABlock ByteString -> m BodyState
updateBody BodyEnvironment
env BodyState
bs ABlock ByteString
b = do
  -- Validate the block size
  ABlock ByteString -> Natural
blockLength ABlock ByteString
b
    forall a. Ord a => a -> a -> Bool
<= Natural
maxBlockSize
    forall e (m :: * -> *).
(MonadError e m, MonadReader ValidationMode m) =>
Bool -> e -> m ()
`orThrowErrorInBlockValidationMode` Natural -> Natural -> ChainValidationError
ChainValidationBlockTooLarge Natural
maxBlockSize (ABlock ByteString -> Natural
blockLength ABlock ByteString
b)

  -- Validate the delegation, transaction, and update payload proofs.
  forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
whenBlockValidation (forall (m :: * -> *).
MonadError ProofValidationError m =>
ABlock ByteString -> m ()
validateBlockProofs ABlock ByteString
b)
    forall e' (m :: * -> *) e a.
(MonadError e' m, MonadReader ValidationMode m) =>
ReaderT ValidationMode (Either e) a -> (e -> e') -> m a
`wrapErrorWithValidationMode` ProofValidationError -> ChainValidationError
ChainValidationProofValidationError

  -- Update the delegation state
  State
delegationState' <-
    forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [ACertificate ByteString] -> m State
DI.updateDelegation Environment
delegationEnv State
delegationState [ACertificate ByteString]
certificates
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> ChainValidationError
ChainValidationDelegationSchedulingError

  -- Update the UTxO
  UTxO
utxo' <-
    forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
utxoEnv UTxO
utxo [ATxAux ByteString]
txs
      forall e' (m :: * -> *) e a.
(MonadError e' m, MonadReader ValidationMode m) =>
ReaderT ValidationMode (Either e) a -> (e -> e') -> m a
`wrapErrorWithValidationMode` UTxOValidationError -> ChainValidationError
ChainValidationUTxOValidationError

  -- Update the update state
  State
updateState' <-
    forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Signal -> m State
UPI.registerUpdate Environment
updateEnv State
updateState Signal
updateSignal
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` SlotNumber -> Error -> ChainValidationError
ChainValidationUpdateError SlotNumber
currentSlot

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ BodyState
      { $sel:utxo:BodyState :: UTxO
utxo = UTxO
utxo'
      , $sel:updateState:BodyState :: State
updateState = State
updateState'
      , $sel:delegationState:BodyState :: State
delegationState = State
delegationState'
      }
  where
    BodyEnvironment
      { AProtocolMagic ByteString
protocolMagic :: AProtocolMagic ByteString
$sel:protocolMagic:BodyEnvironment :: BodyEnvironment -> AProtocolMagic ByteString
protocolMagic
      , BlockCount
k :: BlockCount
$sel:k:BodyEnvironment :: BodyEnvironment -> BlockCount
k
      , Set KeyHash
allowedDelegators :: Set KeyHash
$sel:allowedDelegators:BodyEnvironment :: BodyEnvironment -> Set KeyHash
allowedDelegators
      , UTxOConfiguration
utxoConfiguration :: UTxOConfiguration
$sel:utxoConfiguration:BodyEnvironment :: BodyEnvironment -> UTxOConfiguration
utxoConfiguration
      , EpochNumber
currentEpoch :: EpochNumber
$sel:currentEpoch:BodyEnvironment :: BodyEnvironment -> EpochNumber
currentEpoch
      } = BodyEnvironment
env

    BodyState {UTxO
utxo :: UTxO
$sel:utxo:BodyState :: BodyState -> UTxO
utxo, State
updateState :: State
$sel:updateState:BodyState :: BodyState -> State
updateState, State
delegationState :: State
$sel:delegationState:BodyState :: BodyState -> State
delegationState} = BodyState
bs

    maxBlockSize :: Natural
maxBlockSize =
      ProtocolParameters -> Natural
Update.ppMaxBlockSize forall a b. (a -> b) -> a -> b
$ State -> ProtocolParameters
UPI.adoptedProtocolParameters State
updateState

    currentSlot :: SlotNumber
currentSlot = forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b

    certificates :: [ACertificate ByteString]
certificates = forall a. APayload a -> [ACertificate a]
Delegation.getPayload forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> APayload a
blockDlgPayload ABlock ByteString
b

    txs :: [ATxAux ByteString]
txs = forall a. ATxPayload a -> [ATxAux a]
aUnTxPayload forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> ATxPayload a
blockTxPayload ABlock ByteString
b

    delegationEnv :: Environment
delegationEnv =
      DI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
DI.protocolMagic = forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId AProtocolMagic ByteString
protocolMagic
        , allowedDelegators :: Set KeyHash
DI.allowedDelegators = Set KeyHash
allowedDelegators
        , k :: BlockCount
DI.k = BlockCount
k
        , currentEpoch :: EpochNumber
DI.currentEpoch = EpochNumber
currentEpoch
        , currentSlot :: SlotNumber
DI.currentSlot = SlotNumber
currentSlot
        }

    utxoEnv :: Environment
utxoEnv =
      UTxO.Environment
        { protocolMagic :: AProtocolMagic ByteString
UTxO.protocolMagic = AProtocolMagic ByteString
protocolMagic
        , protocolParameters :: ProtocolParameters
UTxO.protocolParameters = State -> ProtocolParameters
UPI.adoptedProtocolParameters State
updateState
        , utxoConfiguration :: UTxOConfiguration
UTxO.utxoConfiguration = UTxOConfiguration
utxoConfiguration
        }

    updateEnv :: Environment
updateEnv =
      UPI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
UPI.protocolMagic = forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId AProtocolMagic ByteString
protocolMagic
        , k :: BlockCount
UPI.k = BlockCount
k
        , currentSlot :: SlotNumber
UPI.currentSlot = SlotNumber
currentSlot
        , numGenKeys :: Word8
UPI.numGenKeys = forall n. Integral n => n -> Word8
toNumGenKeys forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Int
Set.size Set KeyHash
allowedDelegators
        , delegationMap :: Map
UPI.delegationMap = State -> Map
DI.delegationMap State
delegationState
        }
    updateSignal :: Signal
updateSignal = Maybe (AProposal ByteString)
-> [AVote ByteString] -> Endorsement -> Signal
UPI.Signal Maybe (AProposal ByteString)
updateProposal [AVote ByteString]
updateVotes Endorsement
updateEndorsement

    updateProposal :: Maybe (AProposal ByteString)
updateProposal = forall a. APayload a -> Maybe (AProposal a)
Update.payloadProposal forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> APayload a
blockUpdatePayload ABlock ByteString
b
    updateVotes :: [AVote ByteString]
updateVotes = forall a. APayload a -> [AVote a]
Update.payloadVotes forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> APayload a
blockUpdatePayload ABlock ByteString
b
    updateEndorsement :: Endorsement
updateEndorsement =
      ProtocolVersion -> KeyHash -> Endorsement
Endorsement (forall a. ABlock a -> ProtocolVersion
blockProtocolVersion ABlock ByteString
b) (VerificationKey -> KeyHash
hashKey forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> VerificationKey
blockIssuer ABlock ByteString
b)

toNumGenKeys :: Integral n => n -> Word8
toNumGenKeys :: forall n. Integral n => n -> Word8
toNumGenKeys n
n
  | n
n forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word8) = forall a. HasCallStack => Text -> a
panic Text
"updateBody: Too many genesis keys"
  | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral n
n

-- | This is an implementation of the headerIsValid function from the Byron
--   chain specification
headerIsValid ::
  (MonadError ChainValidationError m, MonadReader ValidationMode m) =>
  UPI.State ->
  AHeader ByteString ->
  m ()
headerIsValid :: forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
State -> AHeader ByteString -> m ()
headerIsValid State
updateState AHeader ByteString
h =
  -- Validate the header size
  AHeader ByteString -> Natural
headerLength AHeader ByteString
h
    forall a. Ord a => a -> a -> Bool
<= Natural
maxHeaderSize
    forall e (m :: * -> *).
(MonadError e m, MonadReader ValidationMode m) =>
Bool -> e -> m ()
`orThrowErrorInBlockValidationMode` Natural -> Natural -> ChainValidationError
ChainValidationHeaderTooLarge Natural
maxHeaderSize (AHeader ByteString -> Natural
headerLength AHeader ByteString
h)
  where
    maxHeaderSize :: Natural
maxHeaderSize = ProtocolParameters -> Natural
Update.ppMaxHeaderSize forall a b. (a -> b) -> a -> b
$ State -> ProtocolParameters
UPI.adoptedProtocolParameters State
updateState

data EpochEnvironment = EpochEnvironment
  { EpochEnvironment -> Annotated ProtocolMagicId ByteString
protocolMagic :: !(Annotated ProtocolMagicId ByteString)
  , EpochEnvironment -> BlockCount
k :: !BlockCount
  , EpochEnvironment -> Set KeyHash
allowedDelegators :: !(Set KeyHash)
  , EpochEnvironment -> Map
delegationMap :: !Delegation.Map
  , EpochEnvironment -> EpochNumber
currentEpoch :: !EpochNumber
  }

-- | Perform epoch transition if we have moved across the epoch boundary
--
--   We pass through to the update interface UPIEC rule, which adopts any
--   confirmed proposals and cleans up the state. This corresponds to the EPOCH
--   rules from the Byron chain specification.
epochTransition ::
  EpochEnvironment ->
  UPI.State ->
  SlotNumber ->
  UPI.State
epochTransition :: EpochEnvironment -> State -> SlotNumber -> State
epochTransition EpochEnvironment
env State
st SlotNumber
slot =
  if EpochNumber
nextEpoch forall a. Ord a => a -> a -> Bool
> EpochNumber
currentEpoch
    then Environment -> State -> EpochNumber -> State
UPI.registerEpoch Environment
updateEnv State
st EpochNumber
nextEpoch
    else State
st
  where
    EpochEnvironment {Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
$sel:protocolMagic:EpochEnvironment :: EpochEnvironment -> Annotated ProtocolMagicId ByteString
protocolMagic, BlockCount
k :: BlockCount
$sel:k:EpochEnvironment :: EpochEnvironment -> BlockCount
k, Set KeyHash
allowedDelegators :: Set KeyHash
$sel:allowedDelegators:EpochEnvironment :: EpochEnvironment -> Set KeyHash
allowedDelegators, Map
delegationMap :: Map
$sel:delegationMap:EpochEnvironment :: EpochEnvironment -> Map
delegationMap, EpochNumber
currentEpoch :: EpochNumber
$sel:currentEpoch:EpochEnvironment :: EpochEnvironment -> EpochNumber
currentEpoch} =
      EpochEnvironment
env

    nextEpoch :: EpochNumber
nextEpoch = EpochSlots -> SlotNumber -> EpochNumber
slotNumberEpoch (BlockCount -> EpochSlots
kEpochSlots BlockCount
k) SlotNumber
slot

    updateEnv :: Environment
updateEnv =
      UPI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
UPI.protocolMagic = Annotated ProtocolMagicId ByteString
protocolMagic
        , k :: BlockCount
UPI.k = BlockCount
k
        , currentSlot :: SlotNumber
UPI.currentSlot = SlotNumber
slot
        , numGenKeys :: Word8
UPI.numGenKeys = forall n. Integral n => n -> Word8
toNumGenKeys forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Int
Set.size Set KeyHash
allowedDelegators
        , delegationMap :: Map
UPI.delegationMap = Map
delegationMap
        }

-- | This represents the CHAIN rule. It is intended more for use in tests than
--   in a real implementation, which will want to invoke its constituent rules
--   directly.
--
--   Note that this also updates the previous block hash, which would usually be
--   done as part of the PBFT rule.
updateBlock ::
  (MonadError ChainValidationError m, MonadReader ValidationMode m) =>
  Genesis.Config ->
  ChainValidationState ->
  ABlock ByteString ->
  m ChainValidationState
updateBlock :: forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
cvs ABlock ByteString
b = do
  -- Compare the block's 'ProtocolMagic' to the configured value
  forall a. ABlock a -> ProtocolMagicId
blockProtocolMagicId ABlock ByteString
b
    forall a. Eq a => a -> a -> Bool
== Config -> ProtocolMagicId
configProtocolMagicId Config
config
    forall e (m :: * -> *).
(MonadError e m, MonadReader ValidationMode m) =>
Bool -> e -> m ()
`orThrowErrorInBlockValidationMode` ProtocolMagicId -> ProtocolMagicId -> ChainValidationError
ChainValidationProtocolMagicMismatch
      (forall a. ABlock a -> ProtocolMagicId
blockProtocolMagicId ABlock ByteString
b)
      (Config -> ProtocolMagicId
configProtocolMagicId Config
config)

  -- Process a potential epoch transition
  let updateState' :: State
updateState' = EpochEnvironment -> State -> SlotNumber -> State
epochTransition EpochEnvironment
epochEnv (ChainValidationState -> State
cvsUpdateState ChainValidationState
cvs) (forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b)

  -- Process header by checking its validity
  forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
State -> AHeader ByteString -> m ()
headerIsValid State
updateState' (forall a. ABlock a -> AHeader a
blockHeader ABlock ByteString
b)

  let bodyEnv :: BodyEnvironment
bodyEnv =
        BodyEnvironment
          { $sel:protocolMagic:BodyEnvironment :: AProtocolMagic ByteString
protocolMagic =
              forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic
                (forall a. ABlock a -> Annotated ProtocolMagicId a
blockAProtocolMagicId ABlock ByteString
b)
                (Config -> RequiresNetworkMagic
configReqNetMagic Config
config)
          , $sel:k:BodyEnvironment :: BlockCount
k = Config -> BlockCount
configK Config
config
          , Set KeyHash
allowedDelegators :: Set KeyHash
$sel:allowedDelegators:BodyEnvironment :: Set KeyHash
allowedDelegators
          , $sel:protocolParameters:BodyEnvironment :: ProtocolParameters
protocolParameters = State -> ProtocolParameters
UPI.adoptedProtocolParameters State
updateState'
          , $sel:utxoConfiguration:BodyEnvironment :: UTxOConfiguration
utxoConfiguration = Config -> UTxOConfiguration
Genesis.configUTxOConfiguration Config
config
          , $sel:currentEpoch:BodyEnvironment :: EpochNumber
currentEpoch = EpochSlots -> SlotNumber -> EpochNumber
slotNumberEpoch (Config -> EpochSlots
configEpochSlots Config
config) (forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b)
          }

      bs :: BodyState
bs =
        BodyState
          { $sel:utxo:BodyState :: UTxO
utxo = ChainValidationState -> UTxO
cvsUtxo ChainValidationState
cvs
          , $sel:updateState:BodyState :: State
updateState = State
updateState'
          , $sel:delegationState:BodyState :: State
delegationState = ChainValidationState -> State
cvsDelegationState ChainValidationState
cvs
          }

  BodyState {UTxO
utxo :: UTxO
$sel:utxo:BodyState :: BodyState -> UTxO
utxo, State
updateState :: State
$sel:updateState:BodyState :: BodyState -> State
updateState, State
delegationState :: State
$sel:delegationState:BodyState :: BodyState -> State
delegationState} <- forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
BodyEnvironment -> BodyState -> ABlock ByteString -> m BodyState
updateBody BodyEnvironment
bodyEnv BodyState
bs ABlock ByteString
b

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ ChainValidationState
cvs
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
cvsLastSlot = forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b
      , $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
cvsPreviousHash = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! ABlock ByteString -> HeaderHash
blockHashAnnotated ABlock ByteString
b
      , $sel:cvsUtxo:ChainValidationState :: UTxO
cvsUtxo = UTxO
utxo
      , $sel:cvsUpdateState:ChainValidationState :: State
cvsUpdateState = State
updateState
      , $sel:cvsDelegationState:ChainValidationState :: State
cvsDelegationState = State
delegationState
      }
  where
    epochEnv :: EpochEnvironment
epochEnv =
      EpochEnvironment
        { $sel:protocolMagic:EpochEnvironment :: Annotated ProtocolMagicId ByteString
protocolMagic = forall a. ABlock a -> Annotated ProtocolMagicId a
blockAProtocolMagicId ABlock ByteString
b
        , $sel:k:EpochEnvironment :: BlockCount
k = Config -> BlockCount
configK Config
config
        , Set KeyHash
allowedDelegators :: Set KeyHash
$sel:allowedDelegators:EpochEnvironment :: Set KeyHash
allowedDelegators
        , Map
delegationMap :: Map
$sel:delegationMap:EpochEnvironment :: Map
delegationMap
        , $sel:currentEpoch:EpochEnvironment :: EpochNumber
currentEpoch = EpochSlots -> SlotNumber -> EpochNumber
slotNumberEpoch (Config -> EpochSlots
configEpochSlots Config
config) (ChainValidationState -> SlotNumber
cvsLastSlot ChainValidationState
cvs)
        }

    allowedDelegators :: Set KeyHash
    allowedDelegators :: Set KeyHash
allowedDelegators = GenesisKeyHashes -> Set KeyHash
unGenesisKeyHashes forall a b. (a -> b) -> a -> b
$ Config -> GenesisKeyHashes
configGenesisKeyHashes Config
config

    delegationMap :: Map
delegationMap = State -> Map
DI.delegationMap forall a b. (a -> b) -> a -> b
$ ChainValidationState -> State
cvsDelegationState ChainValidationState
cvs

--------------------------------------------------------------------------------
-- UTxO
--------------------------------------------------------------------------------

data Error
  = ErrorParseError ParseError
  | ErrorUTxOValidationError EpochAndSlotCount UTxO.UTxOValidationError
  deriving (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

-- | Fold transaction validation over a 'Stream' of 'Block's
foldUTxO ::
  UTxO.Environment ->
  UTxO ->
  Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) () ->
  ExceptT Error (ReaderT ValidationMode ResIO) UTxO
foldUTxO :: Environment
-> UTxO
-> Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
foldUTxO Environment
env UTxO
utxo Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
blocks =
  forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> m x) -> m x -> (x -> m b) -> Stream (Of a) m r -> m b
S.foldM_
    (Environment
-> UTxO
-> ABlock ByteString
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
foldUTxOBlock Environment
env)
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
utxo)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist (forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseError -> Error
ErrorParseError) Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
blocks))

-- | Fold 'updateUTxO' over the transactions in a single 'Block'
foldUTxOBlock ::
  UTxO.Environment ->
  UTxO ->
  ABlock ByteString ->
  ExceptT Error (ReaderT ValidationMode ResIO) UTxO
foldUTxOBlock :: Environment
-> UTxO
-> ABlock ByteString
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
foldUTxOBlock Environment
env UTxO
utxo ABlock ByteString
block =
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
    ( EpochAndSlotCount -> UTxOValidationError -> Error
ErrorUTxOValidationError
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EpochSlots -> SlotNumber -> EpochAndSlotCount
fromSlotNumber EpochSlots
mainnetEpochSlots
        forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> SlotNumber
blockSlot
          ABlock ByteString
block
    )
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
env UTxO
utxo (forall a. ATxPayload a -> [ATxAux a]
aUnTxPayload forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> ATxPayload a
blockTxPayload ABlock ByteString
block)

-- | Size of a heap value, in words
newtype HeapSize a = HeapSize {forall a. HeapSize a -> Int
unHeapSize :: Int}
  deriving (Int -> HeapSize a -> ShowS
forall a. Int -> HeapSize a -> ShowS
forall a. [HeapSize a] -> ShowS
forall a. HeapSize a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeapSize a] -> ShowS
$cshowList :: forall a. [HeapSize a] -> ShowS
show :: HeapSize a -> String
$cshow :: forall a. HeapSize a -> String
showsPrec :: Int -> HeapSize a -> ShowS
$cshowsPrec :: forall a. Int -> HeapSize a -> ShowS
Show)
  deriving newtype (HeapSize a -> Builder
forall a. HeapSize a -> Builder
forall p. (p -> Builder) -> Buildable p
build :: HeapSize a -> Builder
$cbuild :: forall a. HeapSize a -> Builder
Buildable)

-- | Number of entries in the UTxO
newtype UTxOSize = UTxOSize {UTxOSize -> Int
unUTxOSize :: Int}
  deriving (Int -> UTxOSize -> ShowS
[UTxOSize] -> ShowS
UTxOSize -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UTxOSize] -> ShowS
$cshowList :: [UTxOSize] -> ShowS
show :: UTxOSize -> String
$cshow :: UTxOSize -> String
showsPrec :: Int -> UTxOSize -> ShowS
$cshowsPrec :: Int -> UTxOSize -> ShowS
Show)
  deriving newtype (UTxOSize -> Builder
forall p. (p -> Builder) -> Buildable p
build :: UTxOSize -> Builder
$cbuild :: UTxOSize -> Builder
Buildable)

calcUTxOSize :: UTxO -> (HeapSize UTxO, UTxOSize)
calcUTxOSize :: UTxO -> (HeapSize UTxO, UTxOSize)
calcUTxOSize UTxO
utxo =
  ( forall a. Int -> HeapSize a
HeapSize forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. HeapWords a => a -> Int
heapWords forall a b. (a -> b) -> a -> b
$ UTxO -> Map CompactTxIn CompactTxOut
unUTxO UTxO
utxo
  , Int -> UTxOSize
UTxOSize forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> Int
M.size forall a b. (a -> b) -> a -> b
$ UTxO -> Map CompactTxIn CompactTxOut
unUTxO UTxO
utxo
  )