{-# 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.Binary
  ( Annotated (..),
    FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
    enforceSize,
    serialize',
  )
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.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,
    -- | GenesisHash for the previous hash of the zeroth boundary block and
    --   HeaderHash for all others.
    ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash :: !(Either GenesisHash HeaderHash),
    ChainValidationState -> UTxO
cvsUtxo :: !UTxO,
    ChainValidationState -> State
cvsUpdateState :: !UPI.State,
    ChainValidationState -> State
cvsDelegationState :: !DI.State
  }
  deriving (ChainValidationState -> ChainValidationState -> Bool
(ChainValidationState -> ChainValidationState -> Bool)
-> (ChainValidationState -> ChainValidationState -> Bool)
-> Eq ChainValidationState
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
(Int -> ChainValidationState -> ShowS)
-> (ChainValidationState -> String)
-> ([ChainValidationState] -> ShowS)
-> Show ChainValidationState
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. ChainValidationState -> Rep ChainValidationState x)
-> (forall x. Rep ChainValidationState x -> ChainValidationState)
-> Generic ChainValidationState
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 -> ()
(ChainValidationState -> ()) -> NFData ChainValidationState
forall a. (a -> ()) -> NFData a
rnf :: ChainValidationState -> ()
$crnf :: ChainValidationState -> ()
NFData, Context -> ChainValidationState -> IO (Maybe ThunkInfo)
Proxy ChainValidationState -> String
(Context -> ChainValidationState -> IO (Maybe ThunkInfo))
-> (Context -> ChainValidationState -> IO (Maybe ThunkInfo))
-> (Proxy ChainValidationState -> String)
-> NoThunks ChainValidationState
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 FromCBOR ChainValidationState where
  fromCBOR :: Decoder s ChainValidationState
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ChainValidationState" Int
5
    SlotNumber
-> Either GenesisHash HeaderHash
-> UTxO
-> State
-> State
-> ChainValidationState
ChainValidationState
      (SlotNumber
 -> Either GenesisHash HeaderHash
 -> UTxO
 -> State
 -> State
 -> ChainValidationState)
-> Decoder s SlotNumber
-> Decoder
     s
     (Either GenesisHash HeaderHash
      -> UTxO -> State -> State -> ChainValidationState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder
  s
  (Either GenesisHash HeaderHash
   -> UTxO -> State -> State -> ChainValidationState)
-> Decoder s (Either GenesisHash HeaderHash)
-> Decoder s (UTxO -> State -> State -> ChainValidationState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Either GenesisHash HeaderHash)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (UTxO -> State -> State -> ChainValidationState)
-> Decoder s UTxO
-> Decoder s (State -> State -> ChainValidationState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s UTxO
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (State -> State -> ChainValidationState)
-> Decoder s State -> Decoder s (State -> ChainValidationState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s State
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (State -> ChainValidationState)
-> Decoder s State -> Decoder s ChainValidationState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s State
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance ToCBOR ChainValidationState where
  toCBOR :: ChainValidationState -> Encoding
toCBOR ChainValidationState
c =
    Word -> Encoding
encodeListLen Word
5
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ChainValidationState -> SlotNumber
cvsLastSlot ChainValidationState
c)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Either GenesisHash HeaderHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash ChainValidationState
c)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxO -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ChainValidationState -> UTxO
cvsUtxo ChainValidationState
c)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ChainValidationState -> State
cvsUpdateState ChainValidationState
c)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (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 :: Config -> m ChainValidationState
initialChainValidationState Config
config = do
  State
delegationState <- Environment -> GenesisDelegation -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> GenesisDelegation -> m State
DI.initialState Environment
delegationEnv GenesisDelegation
genesisDelegation
  ChainValidationState -> m ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainValidationState -> m ChainValidationState)
-> ChainValidationState -> m ChainValidationState
forall a b. (a -> b) -> a -> b
$
    ChainValidationState :: SlotNumber
-> Either GenesisHash HeaderHash
-> UTxO
-> State
-> State
-> ChainValidationState
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 = GenesisHash -> Either GenesisHash HeaderHash
forall a b. a -> Either a b
Left (GenesisHash -> Either GenesisHash HeaderHash)
-> GenesisHash -> Either GenesisHash HeaderHash
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 =
      Environment :: Annotated ProtocolMagicId ByteString
-> Set KeyHash
-> BlockCount
-> EpochNumber
-> SlotNumber
-> Environment
DI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
DI.protocolMagic = ProtocolMagicId
-> ByteString -> Annotated ProtocolMagicId ByteString
forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pm (ProtocolMagicId -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' ProtocolMagicId
pm),
          allowedDelegators :: Set KeyHash
DI.allowedDelegators = GenesisKeyHashes -> Set KeyHash
unGenesisKeyHashes (GenesisKeyHashes -> Set KeyHash)
-> GenesisKeyHashes -> Set KeyHash
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
(ChainValidationError -> ChainValidationError -> Bool)
-> (ChainValidationError -> ChainValidationError -> Bool)
-> Eq ChainValidationError
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
(Int -> ChainValidationError -> ShowS)
-> (ChainValidationError -> String)
-> ([ChainValidationError] -> ShowS)
-> Show ChainValidationError
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 :: Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> m ChainValidationState
updateChainBlockOrBoundary Config
config ChainValidationState
c ABlockOrBoundary ByteString
b = case ABlockOrBoundary ByteString
b of
  ABOBBoundary ABoundaryBlock ByteString
bvd -> ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
c ABoundaryBlock ByteString
bvd
  ABOBBlock ABlock ByteString
block -> Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
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 :: ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
cvs ABoundaryBlock ByteString
bvd = do
  case (ChainValidationState -> Either GenesisHash HeaderHash
cvsPreviousHash ChainValidationState
cvs, ABoundaryHeader ByteString -> Either GenesisHash HeaderHash
forall a. ABoundaryHeader a -> Either GenesisHash HeaderHash
boundaryPrevHash (ABoundaryBlock ByteString -> ABoundaryHeader ByteString
forall a. ABoundaryBlock a -> ABoundaryHeader a
boundaryHeader ABoundaryBlock ByteString
bvd)) of
    (Left GenesisHash
expected, Left GenesisHash
actual) ->
      (GenesisHash
expected GenesisHash -> GenesisHash -> Bool
forall a. Eq a => a -> a -> Bool
== GenesisHash
actual)
        Bool -> ChainValidationError -> m ()
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 HeaderHash -> HeaderHash -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash
actual)
        Bool -> ChainValidationError -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` HeaderHash -> HeaderHash -> ChainValidationError
ChainValidationInvalidHash HeaderHash
expected HeaderHash
actual
    (Left GenesisHash
gh, Right HeaderHash
hh) ->
      ChainValidationError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainValidationError -> m ()) -> ChainValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ GenesisHash -> HeaderHash -> ChainValidationError
ChainValidationExpectedGenesisHash GenesisHash
gh HeaderHash
hh
    (Right HeaderHash
hh, Left GenesisHash
gh) ->
      ChainValidationError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainValidationError -> m ()) -> ChainValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ HeaderHash -> GenesisHash -> ChainValidationError
ChainValidationExpectedHeaderHash HeaderHash
hh GenesisHash
gh

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

  -- Update the previous hash
  ChainValidationState -> m ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainValidationState -> m ChainValidationState)
-> ChainValidationState -> m ChainValidationState
forall a b. (a -> b) -> a -> b
$
    ChainValidationState
cvs
      { $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
cvsPreviousHash = HeaderHash -> Either GenesisHash HeaderHash
forall a b. b -> Either a b
Right (HeaderHash -> Either GenesisHash HeaderHash)
-> HeaderHash -> Either GenesisHash HeaderHash
forall a b. (a -> b) -> a -> b
$! HeaderHash
previousHash
      }
  where
    previousHash :: HeaderHash
    previousHash :: HeaderHash
previousHash =
      AbstractHash Blake2b_256 Raw -> HeaderHash
coerce
        (AbstractHash Blake2b_256 Raw -> HeaderHash)
-> (ByteString -> AbstractHash Blake2b_256 Raw)
-> ByteString
-> HeaderHash
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> AbstractHash Blake2b_256 Raw
hashRaw
        (ByteString -> AbstractHash Blake2b_256 Raw)
-> (ByteString -> ByteString)
-> ByteString
-> AbstractHash Blake2b_256 Raw
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
        (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
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
        (ByteString -> HeaderHash) -> ByteString -> HeaderHash
forall a b. (a -> b) -> a -> b
$ ABoundaryHeader ByteString -> ByteString
forall a. ABoundaryHeader a -> a
boundaryHeaderAnnotation (ABoundaryBlock ByteString -> ABoundaryHeader ByteString
forall a. ABoundaryBlock a -> ABoundaryHeader a
boundaryHeader ABoundaryBlock ByteString
bvd)

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

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

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

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

validateBlockProofs ::
  MonadError ProofValidationError m =>
  ABlock ByteString ->
  m ()
validateBlockProofs :: ABlock ByteString -> m ()
validateBlockProofs ABlock ByteString
b =
  AHeader ByteString -> ABody ByteString -> m ()
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 :: 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 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxBlockSize
    Bool -> ChainValidationError -> m ()
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.
  ReaderT ValidationMode (Either ProofValidationError) ()
-> ReaderT ValidationMode (Either ProofValidationError) ()
forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
whenBlockValidation (ABlock ByteString
-> ReaderT ValidationMode (Either ProofValidationError) ()
forall (m :: * -> *).
MonadError ProofValidationError m =>
ABlock ByteString -> m ()
validateBlockProofs ABlock ByteString
b)
    ReaderT ValidationMode (Either ProofValidationError) ()
-> (ProofValidationError -> ChainValidationError) -> m ()
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' <-
    Environment
-> State -> [ACertificate ByteString] -> Either Error State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [ACertificate ByteString] -> m State
DI.updateDelegation Environment
delegationEnv State
delegationState [ACertificate ByteString]
certificates
      Either Error State -> (Error -> ChainValidationError) -> m State
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> ChainValidationError
ChainValidationDelegationSchedulingError

  -- Update the UTxO
  UTxO
utxo' <-
    Environment
-> UTxO
-> [ATxAux ByteString]
-> ReaderT ValidationMode (Either UTxOValidationError) UTxO
forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
utxoEnv UTxO
utxo [ATxAux ByteString]
txs
      ReaderT ValidationMode (Either UTxOValidationError) UTxO
-> (UTxOValidationError -> ChainValidationError) -> m UTxO
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' <-
    Environment -> State -> Signal -> Either Error State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Signal -> m State
UPI.registerUpdate Environment
updateEnv State
updateState Signal
updateSignal
      Either Error State -> (Error -> ChainValidationError) -> m State
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` SlotNumber -> Error -> ChainValidationError
ChainValidationUpdateError SlotNumber
currentSlot

  BodyState -> m BodyState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BodyState -> m BodyState) -> BodyState -> m BodyState
forall a b. (a -> b) -> a -> b
$
    BodyState :: UTxO -> State -> State -> BodyState
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 (ProtocolParameters -> Natural) -> ProtocolParameters -> Natural
forall a b. (a -> b) -> a -> b
$ State -> ProtocolParameters
UPI.adoptedProtocolParameters State
updateState

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

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

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

    delegationEnv :: Environment
delegationEnv =
      Environment :: Annotated ProtocolMagicId ByteString
-> Set KeyHash
-> BlockCount
-> EpochNumber
-> SlotNumber
-> Environment
DI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
DI.protocolMagic = AProtocolMagic ByteString -> Annotated ProtocolMagicId ByteString
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 =
      Environment :: AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
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 =
      Environment :: Annotated ProtocolMagicId ByteString
-> BlockCount -> SlotNumber -> Word8 -> Map -> Environment
UPI.Environment
        { protocolMagic :: Annotated ProtocolMagicId ByteString
UPI.protocolMagic = AProtocolMagic ByteString -> Annotated ProtocolMagicId ByteString
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 = Int -> Word8
forall n. Integral n => n -> Word8
toNumGenKeys (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Set KeyHash -> Int
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 = APayload ByteString -> Maybe (AProposal ByteString)
forall a. APayload a -> Maybe (AProposal a)
Update.payloadProposal (APayload ByteString -> Maybe (AProposal ByteString))
-> APayload ByteString -> Maybe (AProposal ByteString)
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> APayload ByteString
forall a. ABlock a -> APayload a
blockUpdatePayload ABlock ByteString
b
    updateVotes :: [AVote ByteString]
updateVotes = APayload ByteString -> [AVote ByteString]
forall a. APayload a -> [AVote a]
Update.payloadVotes (APayload ByteString -> [AVote ByteString])
-> APayload ByteString -> [AVote ByteString]
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> APayload ByteString
forall a. ABlock a -> APayload a
blockUpdatePayload ABlock ByteString
b
    updateEndorsement :: Endorsement
updateEndorsement =
      ProtocolVersion -> KeyHash -> Endorsement
Endorsement (ABlock ByteString -> ProtocolVersion
forall a. ABlock a -> ProtocolVersion
blockProtocolVersion ABlock ByteString
b) (VerificationKey -> KeyHash
hashKey (VerificationKey -> KeyHash) -> VerificationKey -> KeyHash
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> VerificationKey
forall a. ABlock a -> VerificationKey
blockIssuer ABlock ByteString
b)

toNumGenKeys :: Integral n => n -> Word8
toNumGenKeys :: n -> Word8
toNumGenKeys n
n
  | n
n n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> Word8 -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) = Text -> Word8
forall a. HasCallStack => Text -> a
panic Text
"updateBody: Too many genesis keys"
  | Bool
otherwise = n -> Word8
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 :: State -> AHeader ByteString -> m ()
headerIsValid State
updateState AHeader ByteString
h =
  -- Validate the header size
  AHeader ByteString -> Natural
headerLength AHeader ByteString
h Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxHeaderSize
    Bool -> ChainValidationError -> m ()
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 (ProtocolParameters -> Natural) -> ProtocolParameters -> Natural
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 EpochNumber -> EpochNumber -> Bool
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 =
      Environment :: Annotated ProtocolMagicId ByteString
-> BlockCount -> SlotNumber -> Word8 -> Map -> Environment
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 = Int -> Word8
forall n. Integral n => n -> Word8
toNumGenKeys (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Set KeyHash -> Int
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 :: Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
cvs ABlock ByteString
b = do
  -- Compare the block's 'ProtocolMagic' to the configured value
  ABlock ByteString -> ProtocolMagicId
forall a. ABlock a -> ProtocolMagicId
blockProtocolMagicId ABlock ByteString
b ProtocolMagicId -> ProtocolMagicId -> Bool
forall a. Eq a => a -> a -> Bool
== Config -> ProtocolMagicId
configProtocolMagicId Config
config
    Bool -> ChainValidationError -> m ()
forall e (m :: * -> *).
(MonadError e m, MonadReader ValidationMode m) =>
Bool -> e -> m ()
`orThrowErrorInBlockValidationMode` ProtocolMagicId -> ProtocolMagicId -> ChainValidationError
ChainValidationProtocolMagicMismatch
      (ABlock ByteString -> ProtocolMagicId
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) (ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b)

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

  let bodyEnv :: BodyEnvironment
bodyEnv =
        BodyEnvironment :: AProtocolMagic ByteString
-> UTxOConfiguration
-> BlockCount
-> Set KeyHash
-> ProtocolParameters
-> EpochNumber
-> BodyEnvironment
BodyEnvironment
          { $sel:protocolMagic:BodyEnvironment :: AProtocolMagic ByteString
protocolMagic =
              Annotated ProtocolMagicId ByteString
-> RequiresNetworkMagic -> AProtocolMagic ByteString
forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic
                (ABlock ByteString -> Annotated ProtocolMagicId ByteString
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) (ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b)
          }

      bs :: BodyState
bs =
        BodyState :: UTxO -> State -> State -> BodyState
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} <- BodyEnvironment -> BodyState -> ABlock ByteString -> m BodyState
forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
BodyEnvironment -> BodyState -> ABlock ByteString -> m BodyState
updateBody BodyEnvironment
bodyEnv BodyState
bs ABlock ByteString
b

  ChainValidationState -> m ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainValidationState -> m ChainValidationState)
-> ChainValidationState -> m ChainValidationState
forall a b. (a -> b) -> a -> b
$
    ChainValidationState
cvs
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
cvsLastSlot = ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot ABlock ByteString
b,
        $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
cvsPreviousHash = HeaderHash -> Either GenesisHash HeaderHash
forall a b. b -> Either a b
Right (HeaderHash -> Either GenesisHash HeaderHash)
-> HeaderHash -> Either GenesisHash HeaderHash
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 :: Annotated ProtocolMagicId ByteString
-> BlockCount
-> Set KeyHash
-> Map
-> EpochNumber
-> EpochEnvironment
EpochEnvironment
        { $sel:protocolMagic:EpochEnvironment :: Annotated ProtocolMagicId ByteString
protocolMagic = ABlock ByteString -> Annotated ProtocolMagicId ByteString
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 (GenesisKeyHashes -> Set KeyHash)
-> GenesisKeyHashes -> Set KeyHash
forall a b. (a -> b) -> a -> b
$ Config -> GenesisKeyHashes
configGenesisKeyHashes Config
config

    delegationMap :: Map
delegationMap = State -> Map
DI.delegationMap (State -> Map) -> State -> Map
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
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
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
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
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 =
  (UTxO
 -> ABlock ByteString
 -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO)
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
-> (UTxO -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO)
-> Stream
     (Of (ABlock ByteString))
     (ExceptT Error (ReaderT ValidationMode ResIO))
     (Stream (Of (ABlock ByteString)) (ExceptT Error ResIO) ())
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
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)
    (UTxO -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
utxo)
    UTxO -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Stream (Of (ABlock ByteString)) (ExceptT Error ResIO) ()
-> Stream
     (Of (ABlock ByteString))
     (ExceptT Error (ReaderT ValidationMode ResIO))
     (Stream (Of (ABlock ByteString)) (ExceptT Error ResIO) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. ExceptT ParseError ResIO a -> ExceptT Error ResIO a)
-> Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
-> Stream (Of (ABlock ByteString)) (ExceptT Error ResIO) ()
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 ((ParseError -> Error)
-> ExceptT ParseError ResIO a -> ExceptT Error ResIO a
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 =
  (UTxOValidationError -> Error)
-> ExceptT UTxOValidationError (ReaderT ValidationMode ResIO) UTxO
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
    ( EpochAndSlotCount -> UTxOValidationError -> Error
ErrorUTxOValidationError (EpochAndSlotCount -> UTxOValidationError -> Error)
-> (SlotNumber -> EpochAndSlotCount)
-> SlotNumber
-> UTxOValidationError
-> Error
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 (SlotNumber -> UTxOValidationError -> Error)
-> SlotNumber -> UTxOValidationError -> Error
forall a b. (a -> b) -> a -> b
$
        ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot
          ABlock ByteString
block
    )
    (ExceptT UTxOValidationError (ReaderT ValidationMode ResIO) UTxO
 -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO)
-> ExceptT UTxOValidationError (ReaderT ValidationMode ResIO) UTxO
-> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
forall a b. (a -> b) -> a -> b
$ Environment
-> UTxO
-> [ATxAux ByteString]
-> ExceptT UTxOValidationError (ReaderT ValidationMode ResIO) UTxO
forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
env UTxO
utxo (ATxPayload ByteString -> [ATxAux ByteString]
forall a. ATxPayload a -> [ATxAux a]
aUnTxPayload (ATxPayload ByteString -> [ATxAux ByteString])
-> ATxPayload ByteString -> [ATxAux ByteString]
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> ATxPayload ByteString
forall a. ABlock a -> ATxPayload a
blockTxPayload ABlock ByteString
block)

-- | Size of a heap value, in words
newtype HeapSize a = HeapSize {HeapSize a -> Int
unHeapSize :: Int}
  deriving (Int -> HeapSize a -> ShowS
[HeapSize a] -> ShowS
HeapSize a -> String
(Int -> HeapSize a -> ShowS)
-> (HeapSize a -> String)
-> ([HeapSize a] -> ShowS)
-> Show (HeapSize a)
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
(HeapSize a -> Builder) -> Buildable (HeapSize a)
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
(Int -> UTxOSize -> ShowS)
-> (UTxOSize -> String) -> ([UTxOSize] -> ShowS) -> Show UTxOSize
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
(UTxOSize -> Builder) -> Buildable UTxOSize
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 =
  ( Int -> HeapSize UTxO
forall a. Int -> HeapSize a
HeapSize (Int -> HeapSize UTxO)
-> (Map CompactTxIn CompactTxOut -> Int)
-> Map CompactTxIn CompactTxOut
-> HeapSize UTxO
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map CompactTxIn CompactTxOut -> Int
forall a. HeapWords a => a -> Int
heapWords (Map CompactTxIn CompactTxOut -> HeapSize UTxO)
-> Map CompactTxIn CompactTxOut -> HeapSize UTxO
forall a b. (a -> b) -> a -> b
$ UTxO -> Map CompactTxIn CompactTxOut
unUTxO UTxO
utxo,
    Int -> UTxOSize
UTxOSize (Int -> UTxOSize)
-> (Map CompactTxIn CompactTxOut -> Int)
-> Map CompactTxIn CompactTxOut
-> UTxOSize
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map CompactTxIn CompactTxOut -> Int
forall k a. Map k a -> Int
M.size (Map CompactTxIn CompactTxOut -> UTxOSize)
-> Map CompactTxIn CompactTxOut -> UTxOSize
forall a b. (a -> b) -> a -> b
$ UTxO -> Map CompactTxIn CompactTxOut
unUTxO UTxO
utxo
  )