{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
-- | Header validation
module Ouroboros.Consensus.HeaderValidation (
    revalidateHeader
  , validateHeader
    -- * Annotated tips
  , AnnTip (..)
  , HasAnnTip (..)
  , annTipHash
  , annTipPoint
  , annTipRealPoint
  , castAnnTip
  , getAnnTip
  , mapAnnTip
    -- * Header state
  , HeaderState (..)
  , castHeaderState
  , genesisHeaderState
  , headerStateBlockNo
  , headerStatePoint
  , tickHeaderState
    -- * Validate header envelope
  , BasicEnvelopeValidation (..)
  , HeaderEnvelopeError (..)
  , ValidateEnvelope (..)
  , castHeaderEnvelopeError
    -- * Errors
  , HeaderError (..)
  , castHeaderError
    -- * TipInfoIsEBB
  , TipInfoIsEBB (..)
    -- * Serialization
  , decodeAnnTipIsEBB
  , decodeHeaderState
  , defaultDecodeAnnTip
  , defaultEncodeAnnTip
  , encodeAnnTipIsEBB
  , encodeHeaderState
    -- * Type family instances
  , Ticked (..)
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Codec.Serialise (decode, encode)
import           Control.Monad.Except
import           Data.Coerce
import           Data.Kind (Type)
import           Data.Proxy
import           Data.Typeable (Typeable)
import           Data.Void (Void)
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (NoThunks)

import           Cardano.Binary (enforceSize)

import           Ouroboros.Network.AnchoredSeq (Anchorable (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Assert
import qualified Ouroboros.Consensus.Util.CBOR as Util.CBOR

{-------------------------------------------------------------------------------
  Preliminary: annotated tip
-------------------------------------------------------------------------------}

-- | Annotated information about the tip of the chain
--
-- The annotation is the additional information we need to validate the
-- header envelope. Under normal circumstances no additional information is
-- required, but for instance for Byron we need to know if the previous header
-- was an EBB.
data AnnTip blk = AnnTip {
      AnnTip blk -> SlotNo
annTipSlotNo  :: !SlotNo
    , AnnTip blk -> BlockNo
annTipBlockNo :: !BlockNo
    , AnnTip blk -> TipInfo blk
annTipInfo    :: !(TipInfo blk)
    }
  deriving ((forall x. AnnTip blk -> Rep (AnnTip blk) x)
-> (forall x. Rep (AnnTip blk) x -> AnnTip blk)
-> Generic (AnnTip blk)
forall x. Rep (AnnTip blk) x -> AnnTip blk
forall x. AnnTip blk -> Rep (AnnTip blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (AnnTip blk) x -> AnnTip blk
forall blk x. AnnTip blk -> Rep (AnnTip blk) x
$cto :: forall blk x. Rep (AnnTip blk) x -> AnnTip blk
$cfrom :: forall blk x. AnnTip blk -> Rep (AnnTip blk) x
Generic)

deriving instance HasAnnTip blk => Show     (AnnTip blk)
deriving instance HasAnnTip blk => Eq       (AnnTip blk)
deriving instance HasAnnTip blk => NoThunks (AnnTip blk)

annTipHash :: forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash :: AnnTip blk -> HeaderHash blk
annTipHash = Proxy blk -> TipInfo blk -> HeaderHash blk
forall blk (proxy :: * -> *).
HasAnnTip blk =>
proxy blk -> TipInfo blk -> HeaderHash blk
tipInfoHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (TipInfo blk -> HeaderHash blk)
-> (AnnTip blk -> TipInfo blk) -> AnnTip blk -> HeaderHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnTip blk -> TipInfo blk
forall blk. AnnTip blk -> TipInfo blk
annTipInfo

annTipPoint :: forall blk. HasAnnTip blk => AnnTip blk -> Point blk
annTipPoint :: AnnTip blk -> Point blk
annTipPoint annTip :: AnnTip blk
annTip@AnnTip{SlotNo
BlockNo
TipInfo blk
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
..} = SlotNo -> HeaderHash blk -> Point blk
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
annTipSlotNo (AnnTip blk -> HeaderHash blk
forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash AnnTip blk
annTip)

annTipRealPoint :: forall blk. HasAnnTip blk => AnnTip blk -> RealPoint blk
annTipRealPoint :: AnnTip blk -> RealPoint blk
annTipRealPoint annTip :: AnnTip blk
annTip@AnnTip{SlotNo
BlockNo
TipInfo blk
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
..} = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
annTipSlotNo (AnnTip blk -> HeaderHash blk
forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash AnnTip blk
annTip)

castAnnTip :: TipInfo blk ~ TipInfo blk' => AnnTip blk -> AnnTip blk'
castAnnTip :: AnnTip blk -> AnnTip blk'
castAnnTip AnnTip{SlotNo
BlockNo
TipInfo blk
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
..} = AnnTip :: forall blk. SlotNo -> BlockNo -> TipInfo blk -> AnnTip blk
AnnTip{SlotNo
BlockNo
TipInfo blk
TipInfo blk'
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: TipInfo blk'
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
..}

mapAnnTip :: (TipInfo blk -> TipInfo blk') -> AnnTip blk -> AnnTip blk'
mapAnnTip :: (TipInfo blk -> TipInfo blk') -> AnnTip blk -> AnnTip blk'
mapAnnTip TipInfo blk -> TipInfo blk'
f AnnTip { TipInfo blk
annTipInfo :: TipInfo blk
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipInfo, SlotNo
BlockNo
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
.. } = AnnTip :: forall blk. SlotNo -> BlockNo -> TipInfo blk -> AnnTip blk
AnnTip { annTipInfo :: TipInfo blk'
annTipInfo = TipInfo blk -> TipInfo blk'
f TipInfo blk
annTipInfo, SlotNo
BlockNo
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
.. }

class ( StandardHash blk
      , Show     (TipInfo blk)
      , Eq       (TipInfo blk)
      , NoThunks (TipInfo blk)
      ) => HasAnnTip blk where
  type TipInfo blk :: Type
  type TipInfo blk = HeaderHash blk

  -- | Extract 'TipInfo' from a block header
  getTipInfo :: Header blk -> TipInfo blk

  -- | The tip info must at least include the hash
  tipInfoHash :: proxy blk -> TipInfo blk -> HeaderHash blk

  default tipInfoHash :: (TipInfo blk ~ HeaderHash blk)
                      => proxy blk -> TipInfo blk -> HeaderHash blk
  tipInfoHash proxy blk
_ = TipInfo blk -> HeaderHash blk
forall a. a -> a
id

  default getTipInfo :: (TipInfo blk ~ HeaderHash blk, HasHeader (Header blk))
                     => Header blk -> TipInfo blk
  getTipInfo = Header blk -> TipInfo blk
forall b. HasHeader b => b -> HeaderHash b
blockHash

getAnnTip :: (HasHeader (Header blk), HasAnnTip blk)
          => Header blk -> AnnTip blk
getAnnTip :: Header blk -> AnnTip blk
getAnnTip Header blk
hdr = AnnTip :: forall blk. SlotNo -> BlockNo -> TipInfo blk -> AnnTip blk
AnnTip {
      annTipSlotNo :: SlotNo
annTipSlotNo  = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot  Header blk
hdr
    , annTipBlockNo :: BlockNo
annTipBlockNo = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo    Header blk
hdr
    , annTipInfo :: TipInfo blk
annTipInfo    = Header blk -> TipInfo blk
forall blk. HasAnnTip blk => Header blk -> TipInfo blk
getTipInfo Header blk
hdr
    }

{-------------------------------------------------------------------------------
  State
-------------------------------------------------------------------------------}

-- | State required to validate the header
--
-- See 'validateHeader' for details
data HeaderState blk = HeaderState {
      HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip      :: !(WithOrigin (AnnTip blk))
    , HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep :: !(ChainDepState (BlockProtocol blk))
    }
  deriving ((forall x. HeaderState blk -> Rep (HeaderState blk) x)
-> (forall x. Rep (HeaderState blk) x -> HeaderState blk)
-> Generic (HeaderState blk)
forall x. Rep (HeaderState blk) x -> HeaderState blk
forall x. HeaderState blk -> Rep (HeaderState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (HeaderState blk) x -> HeaderState blk
forall blk x. HeaderState blk -> Rep (HeaderState blk) x
$cto :: forall blk x. Rep (HeaderState blk) x -> HeaderState blk
$cfrom :: forall blk x. HeaderState blk -> Rep (HeaderState blk) x
Generic)

-- | Used by 'HeaderStateHistory' but defined here, where it is not an orphan.
instance Anchorable (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) where
  asAnchor :: HeaderState blk -> HeaderState blk
asAnchor = HeaderState blk -> HeaderState blk
forall a. a -> a
id
  getAnchorMeasure :: Proxy (HeaderState blk) -> HeaderState blk -> WithOrigin SlotNo
getAnchorMeasure Proxy (HeaderState blk)
_ = (AnnTip blk -> SlotNo)
-> WithOrigin (AnnTip blk) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnTip blk -> SlotNo
forall blk. AnnTip blk -> SlotNo
annTipSlotNo (WithOrigin (AnnTip blk) -> WithOrigin SlotNo)
-> (HeaderState blk -> WithOrigin (AnnTip blk))
-> HeaderState blk
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip

castHeaderState ::
     ( Coercible (ChainDepState (BlockProtocol blk ))
                 (ChainDepState (BlockProtocol blk'))
     , TipInfo blk ~ TipInfo blk'
     )
  => HeaderState blk -> HeaderState blk'
castHeaderState :: HeaderState blk -> HeaderState blk'
castHeaderState HeaderState {WithOrigin (AnnTip blk)
ChainDepState (BlockProtocol blk)
headerStateChainDep :: ChainDepState (BlockProtocol blk)
headerStateTip :: WithOrigin (AnnTip blk)
headerStateChainDep :: forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateTip :: forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
..} = HeaderState :: forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState {
      headerStateTip :: WithOrigin (AnnTip blk')
headerStateTip      = AnnTip blk -> AnnTip blk'
forall blk blk'.
(TipInfo blk ~ TipInfo blk') =>
AnnTip blk -> AnnTip blk'
castAnnTip (AnnTip blk -> AnnTip blk')
-> WithOrigin (AnnTip blk) -> WithOrigin (AnnTip blk')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (AnnTip blk)
headerStateTip
    , headerStateChainDep :: ChainDepState (BlockProtocol blk')
headerStateChainDep = ChainDepState (BlockProtocol blk)
-> ChainDepState (BlockProtocol blk')
coerce ChainDepState (BlockProtocol blk)
headerStateChainDep
    }

deriving instance (BlockSupportsProtocol blk, HasAnnTip blk)
                => Eq (HeaderState blk)
deriving instance (BlockSupportsProtocol blk, HasAnnTip blk)
                => Show (HeaderState blk)
deriving instance (BlockSupportsProtocol blk, HasAnnTip blk)
                => NoThunks (HeaderState blk)

data instance Ticked (HeaderState blk) = TickedHeaderState {
      Ticked (HeaderState blk) -> WithOrigin (AnnTip blk)
untickedHeaderStateTip    :: WithOrigin (AnnTip blk)
    , Ticked (HeaderState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
tickedHeaderStateChainDep :: Ticked (ChainDepState (BlockProtocol blk))
    }

-- | Tick the 'ChainDepState' inside the 'HeaderState'
tickHeaderState :: ConsensusProtocol (BlockProtocol blk)
                => ConsensusConfig (BlockProtocol blk)
                -> Ticked (LedgerView (BlockProtocol blk))
                -> SlotNo
                -> HeaderState blk -> Ticked (HeaderState blk)
tickHeaderState :: ConsensusConfig (BlockProtocol blk)
-> Ticked (LedgerView (BlockProtocol blk))
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
tickHeaderState ConsensusConfig (BlockProtocol blk)
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView SlotNo
slot HeaderState {WithOrigin (AnnTip blk)
ChainDepState (BlockProtocol blk)
headerStateChainDep :: ChainDepState (BlockProtocol blk)
headerStateTip :: WithOrigin (AnnTip blk)
headerStateChainDep :: forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateTip :: forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
..} = TickedHeaderState :: forall blk.
WithOrigin (AnnTip blk)
-> Ticked (ChainDepState (BlockProtocol blk))
-> Ticked (HeaderState blk)
TickedHeaderState {
      untickedHeaderStateTip :: WithOrigin (AnnTip blk)
untickedHeaderStateTip    = WithOrigin (AnnTip blk)
headerStateTip
    , tickedHeaderStateChainDep :: Ticked (ChainDepState (BlockProtocol blk))
tickedHeaderStateChainDep =
        ConsensusConfig (BlockProtocol blk)
-> Ticked (LedgerView (BlockProtocol blk))
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> Ticked (LedgerView p)
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState ConsensusConfig (BlockProtocol blk)
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView SlotNo
slot ChainDepState (BlockProtocol blk)
headerStateChainDep
    }

genesisHeaderState :: ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState :: ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState = WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState WithOrigin (AnnTip blk)
forall t. WithOrigin t
Origin

headerStateBlockNo :: HeaderState blk -> WithOrigin BlockNo
headerStateBlockNo :: HeaderState blk -> WithOrigin BlockNo
headerStateBlockNo = (AnnTip blk -> BlockNo)
-> WithOrigin (AnnTip blk) -> WithOrigin BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnTip blk -> BlockNo
forall blk. AnnTip blk -> BlockNo
annTipBlockNo (WithOrigin (AnnTip blk) -> WithOrigin BlockNo)
-> (HeaderState blk -> WithOrigin (AnnTip blk))
-> HeaderState blk
-> WithOrigin BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip

headerStatePoint :: HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint :: HeaderState blk -> Point blk
headerStatePoint =
      WithOrigin (RealPoint blk) -> Point blk
forall blk. WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint
    (WithOrigin (RealPoint blk) -> Point blk)
-> (HeaderState blk -> WithOrigin (RealPoint blk))
-> HeaderState blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnTip blk -> RealPoint blk)
-> WithOrigin (AnnTip blk) -> WithOrigin (RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnTip blk -> RealPoint blk
forall blk. HasAnnTip blk => AnnTip blk -> RealPoint blk
annTipRealPoint
    (WithOrigin (AnnTip blk) -> WithOrigin (RealPoint blk))
-> (HeaderState blk -> WithOrigin (AnnTip blk))
-> HeaderState blk
-> WithOrigin (RealPoint blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip

{-------------------------------------------------------------------------------
  Validate header envelope
-------------------------------------------------------------------------------}

data HeaderEnvelopeError blk =
    -- | Invalid block number
    --
    -- We record both the expected and actual block number
    UnexpectedBlockNo !BlockNo !BlockNo

    -- | Invalid slot number
    --
    -- We record both the expected (minimum) and actual slot number
  | UnexpectedSlotNo !SlotNo !SlotNo

    -- | Invalid hash (in the reference to the previous block)
    --
    -- We record the current tip as well as the prev hash of the new block.
  | UnexpectedPrevHash !(WithOrigin (HeaderHash blk)) !(ChainHash blk)

    -- | Block specific envelope error
  | OtherHeaderEnvelopeError !(OtherHeaderEnvelopeError blk)
  deriving ((forall x.
 HeaderEnvelopeError blk -> Rep (HeaderEnvelopeError blk) x)
-> (forall x.
    Rep (HeaderEnvelopeError blk) x -> HeaderEnvelopeError blk)
-> Generic (HeaderEnvelopeError blk)
forall x.
Rep (HeaderEnvelopeError blk) x -> HeaderEnvelopeError blk
forall x.
HeaderEnvelopeError blk -> Rep (HeaderEnvelopeError blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (HeaderEnvelopeError blk) x -> HeaderEnvelopeError blk
forall blk x.
HeaderEnvelopeError blk -> Rep (HeaderEnvelopeError blk) x
$cto :: forall blk x.
Rep (HeaderEnvelopeError blk) x -> HeaderEnvelopeError blk
$cfrom :: forall blk x.
HeaderEnvelopeError blk -> Rep (HeaderEnvelopeError blk) x
Generic)

deriving instance (ValidateEnvelope blk) => Eq   (HeaderEnvelopeError blk)
deriving instance (ValidateEnvelope blk) => Show (HeaderEnvelopeError blk)
deriving instance (ValidateEnvelope blk, Typeable blk)
               => NoThunks (HeaderEnvelopeError blk)

castHeaderEnvelopeError :: ( HeaderHash blk ~ HeaderHash blk'
                           , OtherHeaderEnvelopeError blk ~ OtherHeaderEnvelopeError blk'
                           )
                        => HeaderEnvelopeError blk -> HeaderEnvelopeError blk'
castHeaderEnvelopeError :: HeaderEnvelopeError blk -> HeaderEnvelopeError blk'
castHeaderEnvelopeError = \case
    OtherHeaderEnvelopeError OtherHeaderEnvelopeError blk
err         -> OtherHeaderEnvelopeError blk' -> HeaderEnvelopeError blk'
forall blk. OtherHeaderEnvelopeError blk -> HeaderEnvelopeError blk
OtherHeaderEnvelopeError OtherHeaderEnvelopeError blk
OtherHeaderEnvelopeError blk'
err
    UnexpectedBlockNo  BlockNo
expected BlockNo
actual   -> BlockNo -> BlockNo -> HeaderEnvelopeError blk'
forall blk. BlockNo -> BlockNo -> HeaderEnvelopeError blk
UnexpectedBlockNo  BlockNo
expected BlockNo
actual
    UnexpectedSlotNo   SlotNo
expected SlotNo
actual   -> SlotNo -> SlotNo -> HeaderEnvelopeError blk'
forall blk. SlotNo -> SlotNo -> HeaderEnvelopeError blk
UnexpectedSlotNo   SlotNo
expected SlotNo
actual
    UnexpectedPrevHash WithOrigin (HeaderHash blk)
oldTip   ChainHash blk
prevHash -> WithOrigin (HeaderHash blk')
-> ChainHash blk' -> HeaderEnvelopeError blk'
forall blk.
WithOrigin (HeaderHash blk)
-> ChainHash blk -> HeaderEnvelopeError blk
UnexpectedPrevHash WithOrigin (HeaderHash blk)
WithOrigin (HeaderHash blk')
oldTip (ChainHash blk -> ChainHash blk'
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash ChainHash blk
prevHash)

-- | Ledger-independent envelope validation (block, slot, hash)
class ( HasHeader (Header blk)
      , HasAnnTip blk
      ) => BasicEnvelopeValidation blk where
  -- | The block number of the first block on the chain
  expectedFirstBlockNo :: proxy blk -> BlockNo
  expectedFirstBlockNo proxy blk
_ = Word64 -> BlockNo
BlockNo Word64
0

  -- | Next block number
  expectedNextBlockNo :: proxy blk
                      -> TipInfo blk -- ^ Old tip
                      -> TipInfo blk -- ^ New block
                      -> BlockNo -> BlockNo
  expectedNextBlockNo proxy blk
_ TipInfo blk
_ TipInfo blk
_ = BlockNo -> BlockNo
forall a. Enum a => a -> a
succ

  -- | The smallest possible 'SlotNo'
  --
  -- NOTE: This does not affect the translation between 'SlotNo' and 'EpochNo'.
  -- "Ouroboros.Consensus.HardFork.History" for details.
  minimumPossibleSlotNo :: Proxy blk -> SlotNo
  minimumPossibleSlotNo Proxy blk
_ = Word64 -> SlotNo
SlotNo Word64
0

  -- | Minimum next slot number
  minimumNextSlotNo :: proxy blk
                    -> TipInfo blk -- ^ Old tip
                    -> TipInfo blk -- ^ New block
                    -> SlotNo -> SlotNo
  minimumNextSlotNo proxy blk
_ TipInfo blk
_ TipInfo blk
_ = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ

-- | Validate header envelope
class ( BasicEnvelopeValidation blk
      , GetPrevHash blk
      , Eq       (OtherHeaderEnvelopeError blk)
      , Show     (OtherHeaderEnvelopeError blk)
      , NoThunks (OtherHeaderEnvelopeError blk)
      ) => ValidateEnvelope blk where

  -- | A block-specific error that 'validateEnvelope' can return.
  type OtherHeaderEnvelopeError blk :: Type
  type OtherHeaderEnvelopeError blk = Void

  -- | Do additional envelope checks
  additionalEnvelopeChecks :: TopLevelConfig blk
                           -> Ticked (LedgerView (BlockProtocol blk))
                           -> Header blk
                           -> Except (OtherHeaderEnvelopeError blk) ()
  additionalEnvelopeChecks TopLevelConfig blk
_ Ticked (LedgerView (BlockProtocol blk))
_ Header blk
_ = () -> Except (OtherHeaderEnvelopeError blk) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Validate the header envelope
validateEnvelope :: forall blk. (ValidateEnvelope blk)
                 => TopLevelConfig blk
                 -> Ticked (LedgerView (BlockProtocol blk))
                 -> WithOrigin (AnnTip blk) -- ^ Old tip
                 -> Header blk
                 -> Except (HeaderEnvelopeError blk) ()
validateEnvelope :: TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> WithOrigin (AnnTip blk)
-> Header blk
-> Except (HeaderEnvelopeError blk) ()
validateEnvelope TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView WithOrigin (AnnTip blk)
oldTip Header blk
hdr = do
    Bool
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockNo
actualBlockNo BlockNo -> BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo
expectedBlockNo) (Except (HeaderEnvelopeError blk) ()
 -> Except (HeaderEnvelopeError blk) ())
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$
      HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ())
-> HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$ BlockNo -> BlockNo -> HeaderEnvelopeError blk
forall blk. BlockNo -> BlockNo -> HeaderEnvelopeError blk
UnexpectedBlockNo BlockNo
expectedBlockNo BlockNo
actualBlockNo
    Bool
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SlotNo
actualSlotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
expectedSlotNo) (Except (HeaderEnvelopeError blk) ()
 -> Except (HeaderEnvelopeError blk) ())
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$
      HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ())
-> HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> HeaderEnvelopeError blk
forall blk. SlotNo -> SlotNo -> HeaderEnvelopeError blk
UnexpectedSlotNo SlotNo
expectedSlotNo SlotNo
actualSlotNo
    Bool
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WithOrigin (HeaderHash blk) -> ChainHash blk -> Bool
checkPrevHash' (AnnTip blk -> HeaderHash blk
forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash (AnnTip blk -> HeaderHash blk)
-> WithOrigin (AnnTip blk) -> WithOrigin (HeaderHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (AnnTip blk)
oldTip) ChainHash blk
actualPrevHash) (Except (HeaderEnvelopeError blk) ()
 -> Except (HeaderEnvelopeError blk) ())
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$
      HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ())
-> HeaderEnvelopeError blk -> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$ WithOrigin (HeaderHash blk)
-> ChainHash blk -> HeaderEnvelopeError blk
forall blk.
WithOrigin (HeaderHash blk)
-> ChainHash blk -> HeaderEnvelopeError blk
UnexpectedPrevHash (AnnTip blk -> HeaderHash blk
forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash (AnnTip blk -> HeaderHash blk)
-> WithOrigin (AnnTip blk) -> WithOrigin (HeaderHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (AnnTip blk)
oldTip) ChainHash blk
actualPrevHash
    (OtherHeaderEnvelopeError blk -> HeaderEnvelopeError blk)
-> Except (OtherHeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept OtherHeaderEnvelopeError blk -> HeaderEnvelopeError blk
forall blk. OtherHeaderEnvelopeError blk -> HeaderEnvelopeError blk
OtherHeaderEnvelopeError (Except (OtherHeaderEnvelopeError blk) ()
 -> Except (HeaderEnvelopeError blk) ())
-> Except (OtherHeaderEnvelopeError blk) ()
-> Except (HeaderEnvelopeError blk) ()
forall a b. (a -> b) -> a -> b
$
      TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
additionalEnvelopeChecks TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView Header blk
hdr
  where
    checkPrevHash' :: WithOrigin (HeaderHash blk)
                   -> ChainHash blk
                   -> Bool
    checkPrevHash' :: WithOrigin (HeaderHash blk) -> ChainHash blk -> Bool
checkPrevHash' WithOrigin (HeaderHash blk)
Origin        ChainHash blk
GenesisHash    = Bool
True
    checkPrevHash' (NotOrigin h) (BlockHash HeaderHash blk
h') = HeaderHash blk
h HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
h'
    checkPrevHash' WithOrigin (HeaderHash blk)
_             ChainHash blk
_              = Bool
False

    actualSlotNo   :: SlotNo
    actualBlockNo  :: BlockNo
    actualPrevHash :: ChainHash blk

    actualSlotNo :: SlotNo
actualSlotNo   = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot      Header blk
hdr
    actualBlockNo :: BlockNo
actualBlockNo  = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo        Header blk
hdr
    actualPrevHash :: ChainHash blk
actualPrevHash = Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr

    expectedSlotNo :: SlotNo -- Lower bound only
    expectedSlotNo :: SlotNo
expectedSlotNo =
        case WithOrigin (AnnTip blk)
oldTip of
          WithOrigin (AnnTip blk)
Origin        -> Proxy blk -> SlotNo
forall blk. BasicEnvelopeValidation blk => Proxy blk -> SlotNo
minimumPossibleSlotNo Proxy blk
p
          NotOrigin AnnTip blk
tip -> Proxy blk -> TipInfo blk -> TipInfo blk -> SlotNo -> SlotNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> TipInfo blk -> TipInfo blk -> SlotNo -> SlotNo
minimumNextSlotNo Proxy blk
p (AnnTip blk -> TipInfo blk
forall blk. AnnTip blk -> TipInfo blk
annTipInfo AnnTip blk
tip)
                                               (Header blk -> TipInfo blk
forall blk. HasAnnTip blk => Header blk -> TipInfo blk
getTipInfo Header blk
hdr)
                                               (AnnTip blk -> SlotNo
forall blk. AnnTip blk -> SlotNo
annTipSlotNo AnnTip blk
tip)

    expectedBlockNo  :: BlockNo
    expectedBlockNo :: BlockNo
expectedBlockNo =
        case WithOrigin (AnnTip blk)
oldTip of
          WithOrigin (AnnTip blk)
Origin        -> Proxy blk -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
expectedFirstBlockNo Proxy blk
p
          NotOrigin AnnTip blk
tip -> Proxy blk -> TipInfo blk -> TipInfo blk -> BlockNo -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> TipInfo blk -> TipInfo blk -> BlockNo -> BlockNo
expectedNextBlockNo Proxy blk
p (AnnTip blk -> TipInfo blk
forall blk. AnnTip blk -> TipInfo blk
annTipInfo AnnTip blk
tip)
                                                 (Header blk -> TipInfo blk
forall blk. HasAnnTip blk => Header blk -> TipInfo blk
getTipInfo Header blk
hdr)
                                                 (AnnTip blk -> BlockNo
forall blk. AnnTip blk -> BlockNo
annTipBlockNo AnnTip blk
tip)

    p :: Proxy blk
p = Proxy blk
forall k (t :: k). Proxy t
Proxy @blk

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

-- | Invalid header
data HeaderError blk =
    -- | Invalid consensus protocol fields
    HeaderProtocolError !(ValidationErr (BlockProtocol blk))

    -- | Failed to validate the envelope
  | HeaderEnvelopeError !(HeaderEnvelopeError blk)
  deriving ((forall x. HeaderError blk -> Rep (HeaderError blk) x)
-> (forall x. Rep (HeaderError blk) x -> HeaderError blk)
-> Generic (HeaderError blk)
forall x. Rep (HeaderError blk) x -> HeaderError blk
forall x. HeaderError blk -> Rep (HeaderError blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (HeaderError blk) x -> HeaderError blk
forall blk x. HeaderError blk -> Rep (HeaderError blk) x
$cto :: forall blk x. Rep (HeaderError blk) x -> HeaderError blk
$cfrom :: forall blk x. HeaderError blk -> Rep (HeaderError blk) x
Generic)

deriving instance (BlockSupportsProtocol blk, ValidateEnvelope blk)
               => Eq                 (HeaderError blk)
deriving instance (BlockSupportsProtocol blk, ValidateEnvelope blk)
               => Show               (HeaderError blk)
deriving instance (BlockSupportsProtocol blk, ValidateEnvelope blk, Typeable blk)
               => NoThunks (HeaderError blk)

castHeaderError :: (   ValidationErr (BlockProtocol blk )
                     ~ ValidationErr (BlockProtocol blk')
                   ,   HeaderHash blk
                     ~ HeaderHash blk'
                   ,   OtherHeaderEnvelopeError blk
                     ~ OtherHeaderEnvelopeError blk'
                   )
                => HeaderError blk -> HeaderError blk'
castHeaderError :: HeaderError blk -> HeaderError blk'
castHeaderError (HeaderProtocolError ValidationErr (BlockProtocol blk)
e) = ValidationErr (BlockProtocol blk') -> HeaderError blk'
forall blk. ValidationErr (BlockProtocol blk) -> HeaderError blk
HeaderProtocolError ValidationErr (BlockProtocol blk)
ValidationErr (BlockProtocol blk')
e
castHeaderError (HeaderEnvelopeError HeaderEnvelopeError blk
e) = HeaderEnvelopeError blk' -> HeaderError blk'
forall blk. HeaderEnvelopeError blk -> HeaderError blk
HeaderEnvelopeError (HeaderEnvelopeError blk' -> HeaderError blk')
-> HeaderEnvelopeError blk' -> HeaderError blk'
forall a b. (a -> b) -> a -> b
$
                                            HeaderEnvelopeError blk -> HeaderEnvelopeError blk'
forall blk blk'.
(HeaderHash blk ~ HeaderHash blk',
 OtherHeaderEnvelopeError blk ~ OtherHeaderEnvelopeError blk') =>
HeaderEnvelopeError blk -> HeaderEnvelopeError blk'
castHeaderEnvelopeError HeaderEnvelopeError blk
e

{-------------------------------------------------------------------------------
  Validation proper
-------------------------------------------------------------------------------}

-- | Header validation
--
-- Header validation (as opposed to block validation) is done by the chain sync
-- client: as we download headers from other network nodes, we validate those
-- headers before deciding whether or not to download the corresponding blocks.
--
-- Before we /adopt/ any blocks we have downloaded, however, we will do a full
-- block validation. As such, the header validation check can omit some checks
-- (provided that we do those checks when we do the full validation); at worst,
-- this would mean we might download some blocks that we will reject as being
-- invalid where we could have detected that sooner.
--
-- For this reason, the header validation currently only checks two things:
--
-- o It verifies the consensus part of the header.
--
--   For example, for Praos this means checking the VRF proofs.
--
-- o It verifies the 'HasHeader' part of the header.
--
--   By default, we verify that
--
--   x Block numbers are consecutive
--   x The block number of the first block is 'firstBlockNo'
--   x Slot numbers are strictly increasing
--   x The slot number of the first block is at least 'minimumPossibleSlotNo'
--   x Hashes line up
--
-- /If/ a particular ledger wants to verify additional fields in the header, it
-- will get the chance to do so in 'applyBlockLedgerResult', which is passed the
-- entire block (not just the block body).
validateHeader :: (BlockSupportsProtocol blk, ValidateEnvelope blk)
               => TopLevelConfig blk
               -> Ticked (LedgerView (BlockProtocol blk))
               -> Header blk
               -> Ticked (HeaderState blk)
               -> Except (HeaderError blk) (HeaderState blk)
validateHeader :: TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
validateHeader TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView Header blk
hdr Ticked (HeaderState blk)
st = do
    (HeaderEnvelopeError blk -> HeaderError blk)
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderError blk) ()
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept HeaderEnvelopeError blk -> HeaderError blk
forall blk. HeaderEnvelopeError blk -> HeaderError blk
HeaderEnvelopeError (Except (HeaderEnvelopeError blk) ()
 -> Except (HeaderError blk) ())
-> Except (HeaderEnvelopeError blk) ()
-> Except (HeaderError blk) ()
forall a b. (a -> b) -> a -> b
$
      TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> WithOrigin (AnnTip blk)
-> Header blk
-> Except (HeaderEnvelopeError blk) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> WithOrigin (AnnTip blk)
-> Header blk
-> Except (HeaderEnvelopeError blk) ()
validateEnvelope
        TopLevelConfig blk
cfg
        Ticked (LedgerView (BlockProtocol blk))
ledgerView
        (Ticked (HeaderState blk) -> WithOrigin (AnnTip blk)
forall blk. Ticked (HeaderState blk) -> WithOrigin (AnnTip blk)
untickedHeaderStateTip Ticked (HeaderState blk)
st)
        Header blk
hdr
    ChainDepState (BlockProtocol blk)
chainDepState' <- (ValidationErr (BlockProtocol blk) -> HeaderError blk)
-> Except
     (ValidationErr (BlockProtocol blk))
     (ChainDepState (BlockProtocol blk))
-> Except (HeaderError blk) (ChainDepState (BlockProtocol blk))
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept ValidationErr (BlockProtocol blk) -> HeaderError blk
forall blk. ValidationErr (BlockProtocol blk) -> HeaderError blk
HeaderProtocolError (Except
   (ValidationErr (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk))
 -> Except (HeaderError blk) (ChainDepState (BlockProtocol blk)))
-> Except
     (ValidationErr (BlockProtocol blk))
     (ChainDepState (BlockProtocol blk))
-> Except (HeaderError blk) (ChainDepState (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$
      ConsensusConfig (BlockProtocol blk)
-> ValidateView (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> Except
     (ValidationErr (BlockProtocol blk))
     (ChainDepState (BlockProtocol blk))
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> ValidateView p
-> SlotNo
-> Ticked (ChainDepState p)
-> Except (ValidationErr p) (ChainDepState p)
updateChainDepState
        (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
        (BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg) Header blk
hdr)
        (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
        (Ticked (HeaderState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (HeaderState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
tickedHeaderStateChainDep Ticked (HeaderState blk)
st)
    HeaderState blk -> Except (HeaderError blk) (HeaderState blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderState blk -> Except (HeaderError blk) (HeaderState blk))
-> HeaderState blk -> Except (HeaderError blk) (HeaderState blk)
forall a b. (a -> b) -> a -> b
$ WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState (AnnTip blk -> WithOrigin (AnnTip blk)
forall t. t -> WithOrigin t
NotOrigin (Header blk -> AnnTip blk
forall blk.
(HasHeader (Header blk), HasAnnTip blk) =>
Header blk -> AnnTip blk
getAnnTip Header blk
hdr)) ChainDepState (BlockProtocol blk)
chainDepState'

-- | Header revalidation
--
-- Same as 'validateHeader' but used when the header has been validated before
-- w.r.t. the same exact 'HeaderState'.
--
-- Expensive validation checks are skipped ('reupdateChainDepState' vs.
-- 'updateChainDepState').
revalidateHeader ::
     forall blk. (BlockSupportsProtocol blk, ValidateEnvelope blk, HasCallStack)
  => TopLevelConfig blk
  -> Ticked (LedgerView (BlockProtocol blk))
  -> Header blk
  -> Ticked (HeaderState blk)
  -> HeaderState blk
revalidateHeader :: TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Ticked (HeaderState blk)
-> HeaderState blk
revalidateHeader TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView Header blk
hdr Ticked (HeaderState blk)
st =
    Either String () -> HeaderState blk -> HeaderState blk
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg Either String ()
envelopeCheck (HeaderState blk -> HeaderState blk)
-> HeaderState blk -> HeaderState blk
forall a b. (a -> b) -> a -> b
$
      WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState
        (AnnTip blk -> WithOrigin (AnnTip blk)
forall t. t -> WithOrigin t
NotOrigin (Header blk -> AnnTip blk
forall blk.
(HasHeader (Header blk), HasAnnTip blk) =>
Header blk -> AnnTip blk
getAnnTip Header blk
hdr))
        ChainDepState (BlockProtocol blk)
chainDepState'
  where
    chainDepState' :: ChainDepState (BlockProtocol blk)
    chainDepState' :: ChainDepState (BlockProtocol blk)
chainDepState' =
        ConsensusConfig (BlockProtocol blk)
-> ValidateView (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> ChainDepState (BlockProtocol blk)
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> ValidateView p
-> SlotNo
-> Ticked (ChainDepState p)
-> ChainDepState p
reupdateChainDepState
          (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
          (BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg) Header blk
hdr)
          (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
          (Ticked (HeaderState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
Ticked (HeaderState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
tickedHeaderStateChainDep Ticked (HeaderState blk)
st)

    envelopeCheck :: Either String ()
    envelopeCheck :: Either String ()
envelopeCheck = Except String () -> Either String ()
forall e a. Except e a -> Either e a
runExcept (Except String () -> Either String ())
-> Except String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ (HeaderEnvelopeError blk -> String)
-> Except (HeaderEnvelopeError blk) () -> Except String ()
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept HeaderEnvelopeError blk -> String
forall a. Show a => a -> String
show (Except (HeaderEnvelopeError blk) () -> Except String ())
-> Except (HeaderEnvelopeError blk) () -> Except String ()
forall a b. (a -> b) -> a -> b
$
        TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> WithOrigin (AnnTip blk)
-> Header blk
-> Except (HeaderEnvelopeError blk) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> WithOrigin (AnnTip blk)
-> Header blk
-> Except (HeaderEnvelopeError blk) ()
validateEnvelope
          TopLevelConfig blk
cfg
          Ticked (LedgerView (BlockProtocol blk))
ledgerView
          (Ticked (HeaderState blk) -> WithOrigin (AnnTip blk)
forall blk. Ticked (HeaderState blk) -> WithOrigin (AnnTip blk)
untickedHeaderStateTip Ticked (HeaderState blk)
st)
          Header blk
hdr

{-------------------------------------------------------------------------------
  TipInfoIsEBB
-------------------------------------------------------------------------------}

-- | Reusable strict data type for 'TipInfo' in case the 'TipInfo' should
-- contain 'IsEBB' in addition to the 'HeaderHash'.
data TipInfoIsEBB blk = TipInfoIsEBB !(HeaderHash blk) !IsEBB
  deriving ((forall x. TipInfoIsEBB blk -> Rep (TipInfoIsEBB blk) x)
-> (forall x. Rep (TipInfoIsEBB blk) x -> TipInfoIsEBB blk)
-> Generic (TipInfoIsEBB blk)
forall x. Rep (TipInfoIsEBB blk) x -> TipInfoIsEBB blk
forall x. TipInfoIsEBB blk -> Rep (TipInfoIsEBB blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (TipInfoIsEBB blk) x -> TipInfoIsEBB blk
forall blk x. TipInfoIsEBB blk -> Rep (TipInfoIsEBB blk) x
$cto :: forall blk x. Rep (TipInfoIsEBB blk) x -> TipInfoIsEBB blk
$cfrom :: forall blk x. TipInfoIsEBB blk -> Rep (TipInfoIsEBB blk) x
Generic)

deriving instance StandardHash blk => Eq   (TipInfoIsEBB blk)
deriving instance StandardHash blk => Show (TipInfoIsEBB blk)
deriving instance StandardHash blk => NoThunks (TipInfoIsEBB blk)

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

defaultEncodeAnnTip :: TipInfo blk ~ HeaderHash blk
                    => (HeaderHash blk -> Encoding)
                    -> (AnnTip     blk -> Encoding)
defaultEncodeAnnTip :: (HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
defaultEncodeAnnTip HeaderHash blk -> Encoding
encodeHash AnnTip{SlotNo
BlockNo
TipInfo blk
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
3
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode     SlotNo
annTipSlotNo
    , HeaderHash blk -> Encoding
encodeHash HeaderHash blk
TipInfo blk
annTipInfo
    , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode     BlockNo
annTipBlockNo
    ]

defaultDecodeAnnTip :: TipInfo blk ~ HeaderHash blk
                    => (forall s. Decoder s (HeaderHash blk))
                    -> (forall s. Decoder s (AnnTip     blk))
defaultDecodeAnnTip :: (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
defaultDecodeAnnTip forall s. Decoder s (HeaderHash blk)
decodeHash = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"AnnTip" Int
3
    SlotNo
annTipSlotNo  <- Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
    HeaderHash blk
annTipInfo    <- Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHash
    BlockNo
annTipBlockNo <- Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
    AnnTip blk -> Decoder s (AnnTip blk)
forall (m :: * -> *) a. Monad m => a -> m a
return AnnTip :: forall blk. SlotNo -> BlockNo -> TipInfo blk -> AnnTip blk
AnnTip{SlotNo
BlockNo
HeaderHash blk
TipInfo blk
annTipBlockNo :: BlockNo
annTipInfo :: HeaderHash blk
annTipSlotNo :: SlotNo
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
..}

encodeAnnTipIsEBB :: TipInfo blk ~ TipInfoIsEBB blk
                  => (HeaderHash blk -> Encoding)
                  -> (AnnTip     blk -> Encoding)
encodeAnnTipIsEBB :: (HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
encodeAnnTipIsEBB HeaderHash blk -> Encoding
encodeHash AnnTip{SlotNo
BlockNo
TipInfo blk
annTipInfo :: TipInfo blk
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipInfo :: forall blk. AnnTip blk -> TipInfo blk
annTipBlockNo :: forall blk. AnnTip blk -> BlockNo
annTipSlotNo :: forall blk. AnnTip blk -> SlotNo
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
4
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode     SlotNo
annTipSlotNo
    , HeaderHash blk -> Encoding
encodeHash HeaderHash blk
hash
    , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode     BlockNo
annTipBlockNo
    , IsEBB -> Encoding
encodeInfo IsEBB
isEBB
    ]
  where
    TipInfoIsEBB HeaderHash blk
hash IsEBB
isEBB = TipInfoIsEBB blk
TipInfo blk
annTipInfo

    encodeInfo :: IsEBB -> Encoding
    encodeInfo :: IsEBB -> Encoding
encodeInfo = IsEBB -> Encoding
forall a. Serialise a => a -> Encoding
encode

decodeAnnTipIsEBB :: TipInfo blk ~ TipInfoIsEBB blk
                  => (forall s. Decoder s (HeaderHash blk))
                  -> (forall s. Decoder s (AnnTip     blk))
decodeAnnTipIsEBB :: (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
decodeAnnTipIsEBB forall s. Decoder s (HeaderHash blk)
decodeHash = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"AnnTip" Int
4
    SlotNo
annTipSlotNo  <- Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
    HeaderHash blk
hash          <- Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHash
    BlockNo
annTipBlockNo <- Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
    IsEBB
isEBB         <- Decoder s IsEBB
forall s. Decoder s IsEBB
decodeInfo
    AnnTip blk -> Decoder s (AnnTip blk)
forall (m :: * -> *) a. Monad m => a -> m a
return AnnTip :: forall blk. SlotNo -> BlockNo -> TipInfo blk -> AnnTip blk
AnnTip{annTipInfo :: TipInfo blk
annTipInfo = HeaderHash blk -> IsEBB -> TipInfoIsEBB blk
forall blk. HeaderHash blk -> IsEBB -> TipInfoIsEBB blk
TipInfoIsEBB HeaderHash blk
hash IsEBB
isEBB, SlotNo
BlockNo
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
annTipBlockNo :: BlockNo
annTipSlotNo :: SlotNo
..}
  where
    decodeInfo :: forall s. Decoder s IsEBB
    decodeInfo :: Decoder s IsEBB
decodeInfo = Decoder s IsEBB
forall a s. Serialise a => Decoder s a
decode

encodeHeaderState :: (ChainDepState (BlockProtocol blk) -> Encoding)
                  -> (AnnTip      blk -> Encoding)
                  -> (HeaderState blk -> Encoding)
encodeHeaderState :: (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
encodeHeaderState ChainDepState (BlockProtocol blk) -> Encoding
encodeChainDepState
                  AnnTip blk -> Encoding
encodeAnnTip'
                  HeaderState {WithOrigin (AnnTip blk)
ChainDepState (BlockProtocol blk)
headerStateChainDep :: ChainDepState (BlockProtocol blk)
headerStateTip :: WithOrigin (AnnTip blk)
headerStateChainDep :: forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateTip :: forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , (AnnTip blk -> Encoding) -> WithOrigin (AnnTip blk) -> Encoding
forall a. (a -> Encoding) -> WithOrigin a -> Encoding
Util.CBOR.encodeWithOrigin AnnTip blk -> Encoding
encodeAnnTip' WithOrigin (AnnTip blk)
headerStateTip
    , ChainDepState (BlockProtocol blk) -> Encoding
encodeChainDepState ChainDepState (BlockProtocol blk)
headerStateChainDep
    ]

decodeHeaderState :: (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
                  -> (forall s. Decoder s (AnnTip      blk))
                  -> (forall s. Decoder s (HeaderState blk))
decodeHeaderState :: (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (HeaderState blk)
decodeHeaderState forall s. Decoder s (ChainDepState (BlockProtocol blk))
decodeChainDepState forall s. Decoder s (AnnTip blk)
decodeAnnTip' = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"HeaderState" Int
2
    WithOrigin (AnnTip blk)
headerStateTip      <- Decoder s (AnnTip blk) -> Decoder s (WithOrigin (AnnTip blk))
forall s a. Decoder s a -> Decoder s (WithOrigin a)
Util.CBOR.decodeWithOrigin Decoder s (AnnTip blk)
forall s. Decoder s (AnnTip blk)
decodeAnnTip'
    ChainDepState (BlockProtocol blk)
headerStateChainDep <- Decoder s (ChainDepState (BlockProtocol blk))
forall s. Decoder s (ChainDepState (BlockProtocol blk))
decodeChainDepState
    HeaderState blk -> Decoder s (HeaderState blk)
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderState :: forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState {WithOrigin (AnnTip blk)
ChainDepState (BlockProtocol blk)
headerStateChainDep :: ChainDepState (BlockProtocol blk)
headerStateTip :: WithOrigin (AnnTip blk)
headerStateChainDep :: ChainDepState (BlockProtocol blk)
headerStateTip :: WithOrigin (AnnTip blk)
..}