{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | HeaderState history
--
-- Intended for qualified import
--
-- > import           Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory)
-- > import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory
module Ouroboros.Consensus.HeaderStateHistory
  ( HeaderStateHistory (..)
  , cast
  , current
  , rewind
  , trim

    -- * 'HeaderStateWithTime'
  , HeaderStateWithTime (..)
  , castHeaderStateWithTime
  , mkHeaderStateWithTime
  , mkHeaderStateWithTimeFromSummary

    -- * Validation
  , validateHeader

    -- * Support for tests
  , fromChain
  ) where

import Control.Monad.Except (Except)
import Data.Coerce (Coercible)
import qualified Data.List.NonEmpty as NE
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime (RelativeTime)
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
import Ouroboros.Consensus.HardFork.History (Summary)
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import Ouroboros.Consensus.HeaderValidation hiding (validateHeader)
import qualified Ouroboros.Consensus.HeaderValidation as HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs)
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Util.CallStack (HasCallStack)
import Ouroboros.Network.AnchoredSeq (Anchorable, AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredSeq as AS
import Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain

-- | Maintain a history of 'HeaderStateWithTime's.
newtype HeaderStateHistory blk = HeaderStateHistory
  { forall blk.
HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
unHeaderStateHistory ::
      AnchoredSeq
        (WithOrigin SlotNo)
        (HeaderStateWithTime blk)
        (HeaderStateWithTime blk)
  }
  deriving (forall x.
 HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x)
-> (forall x.
    Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk)
-> Generic (HeaderStateHistory blk)
forall x. Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk
forall x. HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk
forall blk x.
HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x
$cfrom :: forall blk x.
HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x
from :: forall x. HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x
$cto :: forall blk x.
Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk
to :: forall x. Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk
Generic

deriving stock instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  Eq (HeaderStateHistory blk)
deriving stock instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  Show (HeaderStateHistory blk)
deriving newtype instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  NoThunks (HeaderStateHistory blk)

current :: HeaderStateHistory blk -> HeaderStateWithTime blk
current :: forall blk. HeaderStateHistory blk -> HeaderStateWithTime blk
current = (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> HeaderStateWithTime blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
 -> HeaderStateWithTime blk)
-> (HeaderStateHistory blk
    -> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk))
-> HeaderStateHistory blk
-> HeaderStateWithTime blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AS.head (AnchoredSeq
   (WithOrigin SlotNo)
   (HeaderStateWithTime blk)
   (HeaderStateWithTime blk)
 -> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk))
-> (HeaderStateHistory blk
    -> AnchoredSeq
         (WithOrigin SlotNo)
         (HeaderStateWithTime blk)
         (HeaderStateWithTime blk))
-> HeaderStateHistory blk
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall blk.
HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
unHeaderStateHistory

-- | Append a 'HeaderState' to the history.
append :: HeaderStateWithTime blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append :: forall blk.
HeaderStateWithTime blk
-> HeaderStateHistory blk -> HeaderStateHistory blk
append HeaderStateWithTime blk
h (HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history) = AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
HeaderStateHistory (AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateWithTime blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> HeaderStateWithTime blk
h)

-- | Trim the 'HeaderStateHistory' to the given size, dropping the oldest
-- snapshots. The anchor will be shifted accordingly.
--
-- Note that we do not include the anchor in the size. For example, trimming to
-- 0 results in no snapshots but still an anchor. Trimming to 1 results in 1
-- snapshot and an anchor.
trim :: Int -> HeaderStateHistory blk -> HeaderStateHistory blk
trim :: forall blk. Int -> HeaderStateHistory blk -> HeaderStateHistory blk
trim Int
n (HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history) =
  AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
HeaderStateHistory (Word64
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AS.anchorNewest (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history)

cast ::
  ( Coercible
      (ChainDepState (BlockProtocol blk))
      (ChainDepState (BlockProtocol blk'))
  , TipInfo blk ~ TipInfo blk'
  ) =>
  HeaderStateHistory blk -> HeaderStateHistory blk'
cast :: forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderStateHistory blk -> HeaderStateHistory blk'
cast (HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history) =
  AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk')
  (HeaderStateWithTime blk')
-> HeaderStateHistory blk'
forall blk.
AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
HeaderStateHistory (AnchoredSeq
   (WithOrigin SlotNo)
   (HeaderStateWithTime blk')
   (HeaderStateWithTime blk')
 -> HeaderStateHistory blk')
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk')
     (HeaderStateWithTime blk')
-> HeaderStateHistory blk'
forall a b. (a -> b) -> a -> b
$
    (HeaderStateWithTime blk -> HeaderStateWithTime blk')
-> (HeaderStateWithTime blk -> HeaderStateWithTime blk')
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk')
     (HeaderStateWithTime blk')
forall v2 a2 b2 a1 b1 v1.
Anchorable v2 a2 b2 =>
(a1 -> a2)
-> (b1 -> b2) -> AnchoredSeq v1 a1 b1 -> AnchoredSeq v2 a2 b2
AS.bimap HeaderStateWithTime blk -> HeaderStateWithTime blk'
forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderStateWithTime blk -> HeaderStateWithTime blk'
castHeaderStateWithTime HeaderStateWithTime blk -> HeaderStateWithTime blk'
forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderStateWithTime blk -> HeaderStateWithTime blk'
castHeaderStateWithTime AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history

-- | \( O\(n\) \). Rewind the header state history
--
-- We also return the oldest 'HeaderStateWithTime' that was rewound, if any.
--
-- NOTE: we don't distinguish headers of regular blocks from headers of EBBs.
-- Whenever we use \"header\" it can be either. In practice, EBB headers do not
-- affect the 'ChainDepState', but they /do/ affect the 'AnnTip'.
--
-- PRECONDITION: the point to rewind to must correspond to a header (or
-- 'GenesisPoint') that was previously applied to the header state history.
--
-- Rewinding the header state history is intended to be used when switching to a
-- fork, longer or equally long to the chain to which the current header state
-- corresponds. So each rewinding should be followed by rolling forward (using
-- 'headerStateHistoryPush') at least as many blocks that we have rewound.
--
-- Note that repeatedly rewinding a header state history does not make it
-- possible to rewind it all the way to genesis (this would mean that the whole
-- historical header state is accumulated or derivable from the current header
-- state history). For example, rewinding a header state by @i@ blocks and then
-- rewinding that header state again by @j@ where @i + j > k@ is not possible
-- and will yield 'Nothing'.
rewind ::
  forall blk.
  HasAnnTip blk =>
  Point blk ->
  HeaderStateHistory blk ->
  Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
rewind :: forall blk.
HasAnnTip blk =>
Point blk
-> HeaderStateHistory blk
-> Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
rewind Point blk
p (HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history) = do
  (prefix, suffix) <-
    WithOrigin SlotNo
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> Bool)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
-> Maybe
     (AnchoredSeq
        (WithOrigin SlotNo)
        (HeaderStateWithTime blk)
        (HeaderStateWithTime blk),
      AnchoredSeq
        (WithOrigin SlotNo)
        (HeaderStateWithTime blk)
        (HeaderStateWithTime blk))
forall v a b.
Anchorable v a b =>
v
-> (Either a b -> Bool)
-> AnchoredSeq v a b
-> Maybe (AnchoredSeq v a b, AnchoredSeq v a b)
AS.splitAfterMeasure
      (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
p)
      ((Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
p) (Point blk -> Bool)
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> Point blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> Point blk)
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> HeaderState blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState (HeaderStateWithTime blk -> HeaderState blk)
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> HeaderState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> HeaderStateWithTime blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id)
      AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history
  let oldestRewound = case AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
suffix of
        AS.Empty HeaderStateWithTime blk
_ -> Maybe (HeaderStateWithTime blk)
forall a. Maybe a
Nothing
        HeaderStateWithTime blk
hswt AS.:< AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
_ -> HeaderStateWithTime blk -> Maybe (HeaderStateWithTime blk)
forall a. a -> Maybe a
Just HeaderStateWithTime blk
hswt
  pure (HeaderStateHistory prefix, oldestRewound)

{-------------------------------------------------------------------------------
  HeaderStateWithTime
-------------------------------------------------------------------------------}

-- | A 'HeaderState' together with the 'RelativeTime' corresponding to the tip
-- slot of the state. For a state at 'Origin', we use the same time as for slot
-- 0.
data HeaderStateWithTime blk = HeaderStateWithTime
  { forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState :: !(HeaderState blk)
  , forall blk. HeaderStateWithTime blk -> RelativeTime
hswtSlotTime :: !RelativeTime
  }
  deriving stock (forall x.
 HeaderStateWithTime blk -> Rep (HeaderStateWithTime blk) x)
-> (forall x.
    Rep (HeaderStateWithTime blk) x -> HeaderStateWithTime blk)
-> Generic (HeaderStateWithTime blk)
forall x.
Rep (HeaderStateWithTime blk) x -> HeaderStateWithTime blk
forall x.
HeaderStateWithTime blk -> Rep (HeaderStateWithTime blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (HeaderStateWithTime blk) x -> HeaderStateWithTime blk
forall blk x.
HeaderStateWithTime blk -> Rep (HeaderStateWithTime blk) x
$cfrom :: forall blk x.
HeaderStateWithTime blk -> Rep (HeaderStateWithTime blk) x
from :: forall x.
HeaderStateWithTime blk -> Rep (HeaderStateWithTime blk) x
$cto :: forall blk x.
Rep (HeaderStateWithTime blk) x -> HeaderStateWithTime blk
to :: forall x.
Rep (HeaderStateWithTime blk) x -> HeaderStateWithTime blk
Generic

deriving stock instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  Eq (HeaderStateWithTime blk)
deriving stock instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  Show (HeaderStateWithTime blk)
deriving anyclass instance
  (BlockSupportsProtocol blk, HasAnnTip blk) =>
  NoThunks (HeaderStateWithTime blk)

instance Anchorable (WithOrigin SlotNo) (HeaderStateWithTime blk) (HeaderStateWithTime blk) where
  asAnchor :: HeaderStateWithTime blk -> HeaderStateWithTime blk
asAnchor = HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id
  getAnchorMeasure :: Proxy (HeaderStateWithTime blk)
-> HeaderStateWithTime blk -> WithOrigin SlotNo
getAnchorMeasure Proxy (HeaderStateWithTime blk)
_ = (AnnTip blk -> SlotNo)
-> WithOrigin (AnnTip blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> WithOrigin a -> WithOrigin b
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)
-> (HeaderStateWithTime blk -> WithOrigin (AnnTip blk))
-> HeaderStateWithTime 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 (HeaderState blk -> WithOrigin (AnnTip blk))
-> (HeaderStateWithTime blk -> HeaderState blk)
-> HeaderStateWithTime blk
-> WithOrigin (AnnTip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState

castHeaderStateWithTime ::
  ( Coercible
      (ChainDepState (BlockProtocol blk))
      (ChainDepState (BlockProtocol blk'))
  , TipInfo blk ~ TipInfo blk'
  ) =>
  HeaderStateWithTime blk -> HeaderStateWithTime blk'
castHeaderStateWithTime :: forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderStateWithTime blk -> HeaderStateWithTime blk'
castHeaderStateWithTime HeaderStateWithTime blk
hswt =
  HeaderStateWithTime
    { hswtHeaderState :: HeaderState blk'
hswtHeaderState = HeaderState blk -> HeaderState blk'
forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderState blk -> HeaderState blk'
castHeaderState (HeaderState blk -> HeaderState blk')
-> HeaderState blk -> HeaderState blk'
forall a b. (a -> b) -> a -> b
$ HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState HeaderStateWithTime blk
hswt
    , hswtSlotTime :: RelativeTime
hswtSlotTime = HeaderStateWithTime blk -> RelativeTime
forall blk. HeaderStateWithTime blk -> RelativeTime
hswtSlotTime HeaderStateWithTime blk
hswt
    }

mkHeaderStateWithTimeFromSummary ::
  (HasCallStack, HasAnnTip blk) =>
  -- | Must be able to convert the tip slot of the 'HeaderState' to a time.
  Summary (HardForkIndices blk) ->
  HeaderState blk ->
  HeaderStateWithTime blk
mkHeaderStateWithTimeFromSummary :: forall blk.
(HasCallStack, HasAnnTip blk) =>
Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
mkHeaderStateWithTimeFromSummary Summary (HardForkIndices blk)
summary HeaderState blk
hst =
  HeaderStateWithTime
    { hswtHeaderState :: HeaderState blk
hswtHeaderState = HeaderState blk
hst
    , hswtSlotTime :: RelativeTime
hswtSlotTime = RelativeTime
slotTime
    }
 where
  (RelativeTime
slotTime, SlotLength
_) = Qry (RelativeTime, SlotLength)
-> Summary (HardForkIndices blk) -> (RelativeTime, SlotLength)
forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> a
Qry.runQueryPure Qry (RelativeTime, SlotLength)
qry Summary (HardForkIndices blk)
summary
  qry :: Qry (RelativeTime, SlotLength)
qry = SlotNo -> Qry (RelativeTime, SlotLength)
Qry.slotToWallclock SlotNo
slot
  slot :: SlotNo
slot = SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (WithOrigin SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo) -> Point blk -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint HeaderState blk
hst

mkHeaderStateWithTime ::
  (HasCallStack, HasHardForkHistory blk, HasAnnTip blk) =>
  LedgerConfig blk ->
  ExtLedgerState blk mk ->
  HeaderStateWithTime blk
mkHeaderStateWithTime :: forall blk (mk :: MapKind).
(HasCallStack, HasHardForkHistory blk, HasAnnTip blk) =>
LedgerConfig blk
-> ExtLedgerState blk mk -> HeaderStateWithTime blk
mkHeaderStateWithTime LedgerConfig blk
lcfg (ExtLedgerState LedgerState blk mk
lst HeaderState blk
hst) =
  Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
forall blk.
(HasCallStack, HasAnnTip blk) =>
Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
mkHeaderStateWithTimeFromSummary Summary (HardForkIndices blk)
summary HeaderState blk
hst
 where
  -- A summary can always translate the tip slot of the ledger state it was
  -- created from.
  summary :: Summary (HardForkIndices blk)
summary = LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
lcfg LedgerState blk mk
lst

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

-- | Variation on 'HeaderValidation.validateHeader' that maintains a
-- 'HeaderStateHistory'.
--
-- This is used only in the chain sync client for header-only validation.
--
-- Note: this function does not trim the 'HeaderStateHistory'.
validateHeader ::
  forall blk.
  (BlockSupportsProtocol blk, ValidateEnvelope blk) =>
  TopLevelConfig blk ->
  LedgerView (BlockProtocol blk) ->
  Header blk ->
  -- | The time of the slot of the header.
  RelativeTime ->
  HeaderStateHistory blk ->
  Except (HeaderError blk) (HeaderStateHistory blk)
validateHeader :: forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> RelativeTime
-> HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
validateHeader TopLevelConfig blk
cfg LedgerView (BlockProtocol blk)
lv Header blk
hdr RelativeTime
slotTime HeaderStateHistory blk
history = do
  st' <- TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
HeaderValidation.validateHeader TopLevelConfig blk
cfg LedgerView (BlockProtocol blk)
lv Header blk
hdr Ticked (HeaderState blk)
st
  return $ append (HeaderStateWithTime st' slotTime) history
 where
  st :: Ticked (HeaderState blk)
  st :: Ticked (HeaderState blk)
st =
    ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
tickHeaderState
      (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
      LedgerView (BlockProtocol blk)
lv
      (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
      (HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState (HeaderStateWithTime blk -> HeaderState blk)
-> HeaderStateWithTime blk -> HeaderState blk
forall a b. (a -> b) -> a -> b
$ HeaderStateHistory blk -> HeaderStateWithTime blk
forall blk. HeaderStateHistory blk -> HeaderStateWithTime blk
current HeaderStateHistory blk
history)

{-------------------------------------------------------------------------------
  Support for tests
-------------------------------------------------------------------------------}

-- | Create a 'HeaderStateHistory' corresponding to the blocks in the given
-- 'Chain'.
--
-- PRECONDITION: the blocks in the chain are valid.
fromChain ::
  forall blk.
  ( ApplyBlock (ExtLedgerState blk) blk
  , HasHardForkHistory blk
  , HasAnnTip blk
  ) =>
  TopLevelConfig blk ->
  -- | Initial ledger state
  ExtLedgerState blk ValuesMK ->
  Chain blk ->
  HeaderStateHistory blk
fromChain :: forall blk.
(ApplyBlock (ExtLedgerState blk) blk, HasHardForkHistory blk,
 HasAnnTip blk) =>
TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> Chain blk
-> HeaderStateHistory blk
fromChain TopLevelConfig blk
cfg ExtLedgerState blk ValuesMK
initState Chain blk
chain =
  AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateHistory blk
HeaderStateHistory (HeaderStateWithTime blk
-> [HeaderStateWithTime blk]
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AS.fromOldestFirst HeaderStateWithTime blk
anchorSnapshot [HeaderStateWithTime blk]
snapshots)
 where
  HeaderStateWithTime blk
anchorSnapshot NE.:| [HeaderStateWithTime blk]
snapshots =
    (ExtLedgerState blk ValuesMK -> HeaderStateWithTime blk)
-> NonEmpty (ExtLedgerState blk ValuesMK)
-> NonEmpty (HeaderStateWithTime blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LedgerConfig blk
-> ExtLedgerState blk ValuesMK -> HeaderStateWithTime blk
forall blk (mk :: MapKind).
(HasCallStack, HasHardForkHistory blk, HasAnnTip blk) =>
LedgerConfig blk
-> ExtLedgerState blk mk -> HeaderStateWithTime blk
mkHeaderStateWithTime (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg))
      (NonEmpty (ExtLedgerState blk ValuesMK)
 -> NonEmpty (HeaderStateWithTime blk))
-> (Chain blk -> NonEmpty (ExtLedgerState blk ValuesMK))
-> Chain blk
-> NonEmpty (HeaderStateWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtLedgerState blk ValuesMK -> blk -> ExtLedgerState blk ValuesMK)
-> ExtLedgerState blk ValuesMK
-> [blk]
-> NonEmpty (ExtLedgerState blk ValuesMK)
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl
        (\ExtLedgerState blk ValuesMK
st blk
blk -> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs ExtLedgerState blk ValuesMK
st (ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK)
-> ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK
forall a b. (a -> b) -> a -> b
$ ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply ComputeLedgerEvents
OmitLedgerEvents (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg) blk
blk ExtLedgerState blk ValuesMK
st)
        ExtLedgerState blk ValuesMK
initState
      ([blk] -> NonEmpty (ExtLedgerState blk ValuesMK))
-> (Chain blk -> [blk])
-> Chain blk
-> NonEmpty (ExtLedgerState blk ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst
      (Chain blk -> NonEmpty (HeaderStateWithTime blk))
-> Chain blk -> NonEmpty (HeaderStateWithTime blk)
forall a b. (a -> b) -> a -> b
$ Chain blk
chain