{-# 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.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
    (AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
prefix, AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
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 :: Maybe (HeaderStateWithTime blk)
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
    (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
-> Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)
prefix, Maybe (HeaderStateWithTime blk)
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)
  => Summary (HardForkIndices blk)
     -- ^ Must be able to convert the tip slot of the 'HeaderState' to a time.
  -> 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
  -> HeaderStateWithTime blk
mkHeaderStateWithTime :: forall blk.
(HasCallStack, HasHardForkHistory blk, HasAnnTip blk) =>
LedgerConfig blk -> ExtLedgerState blk -> HeaderStateWithTime blk
mkHeaderStateWithTime LedgerConfig blk
lcfg (ExtLedgerState LedgerState blk
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 -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
lcfg LedgerState blk
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
  -> RelativeTime
     -- ^ The time of the slot of the header.
  -> 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
    HeaderState blk
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
    HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
forall a. a -> ExceptT (HeaderError blk) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderStateHistory blk
 -> Except (HeaderError blk) (HeaderStateHistory blk))
-> HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$ HeaderStateWithTime blk
-> HeaderStateHistory blk -> HeaderStateHistory blk
forall blk.
HeaderStateWithTime blk
-> HeaderStateHistory blk -> HeaderStateHistory blk
append (HeaderState blk -> RelativeTime -> HeaderStateWithTime blk
forall blk.
HeaderState blk -> RelativeTime -> HeaderStateWithTime blk
HeaderStateWithTime HeaderState blk
st' RelativeTime
slotTime) HeaderStateHistory blk
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
  -> ExtLedgerState blk
     -- ^ Initial ledger state
  -> Chain blk
  -> HeaderStateHistory blk
fromChain :: forall blk.
(ApplyBlock (ExtLedgerState blk) blk, HasHardForkHistory blk,
 HasAnnTip blk) =>
TopLevelConfig blk
-> ExtLedgerState blk -> Chain blk -> HeaderStateHistory blk
fromChain TopLevelConfig blk
cfg ExtLedgerState blk
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 -> HeaderStateWithTime blk)
-> NonEmpty (ExtLedgerState blk)
-> 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 -> HeaderStateWithTime blk
forall blk.
(HasCallStack, HasHardForkHistory blk, HasAnnTip blk) =>
LedgerConfig blk -> ExtLedgerState blk -> HeaderStateWithTime blk
mkHeaderStateWithTime (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg))
        (NonEmpty (ExtLedgerState blk)
 -> NonEmpty (HeaderStateWithTime blk))
-> (Chain blk -> NonEmpty (ExtLedgerState blk))
-> Chain blk
-> NonEmpty (HeaderStateWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtLedgerState blk -> blk -> ExtLedgerState blk)
-> ExtLedgerState blk -> [blk] -> NonEmpty (ExtLedgerState blk)
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl
            ((blk -> ExtLedgerState blk -> ExtLedgerState blk)
-> ExtLedgerState blk -> blk -> ExtLedgerState blk
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LedgerCfg (ExtLedgerState blk)
-> blk -> ExtLedgerState blk -> ExtLedgerState blk
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg)))
            ExtLedgerState blk
initState
        ([blk] -> NonEmpty (ExtLedgerState blk))
-> (Chain blk -> [blk])
-> Chain blk
-> NonEmpty (ExtLedgerState blk)
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