{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
-- | 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
    -- * Validation
  , validateHeader
    -- * Support for tests
  , fromChain
  ) where

import           Control.Monad.Except (Except)
import           Data.Coerce (Coercible)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Network.AnchoredSeq (AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredSeq as AS

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderValidation hiding (validateHeader)
import qualified Ouroboros.Consensus.HeaderValidation as HeaderValidation
import           Ouroboros.Consensus.Protocol.Abstract

-- Support for tests
import qualified Data.List.NonEmpty as NE
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Network.MockChain.Chain (Chain)
import qualified Ouroboros.Network.MockChain.Chain as Chain

-- | Maintain a history of 'HeaderState's.
newtype HeaderStateHistory blk = HeaderStateHistory {
      HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
unHeaderStateHistory ::
           AnchoredSeq
             (WithOrigin SlotNo)
             (HeaderState blk)
             (HeaderState 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
$cto :: forall blk x.
Rep (HeaderStateHistory blk) x -> HeaderStateHistory blk
$cfrom :: forall blk x.
HeaderStateHistory blk -> Rep (HeaderStateHistory blk) x
Generic)

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

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

-- | Append a 'HeaderState' to the history.
append :: HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append :: HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append HeaderState blk
h (HeaderStateHistory AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history) = AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
HeaderStateHistory (AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderState blk
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> HeaderState 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 :: Int -> HeaderStateHistory blk -> HeaderStateHistory blk
trim Int
n (HeaderStateHistory AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history) =
    AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
HeaderStateHistory (Word64
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState 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) (HeaderState blk) (HeaderState blk)
history)

cast ::
     ( Coercible (ChainDepState (BlockProtocol blk ))
                 (ChainDepState (BlockProtocol blk'))
     , TipInfo blk ~ TipInfo blk'
     )
  => HeaderStateHistory blk -> HeaderStateHistory blk'
cast :: HeaderStateHistory blk -> HeaderStateHistory blk'
cast (HeaderStateHistory AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history) =
    AnchoredSeq
  (WithOrigin SlotNo) (HeaderState blk') (HeaderState blk')
-> HeaderStateHistory blk'
forall blk.
AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
HeaderStateHistory (AnchoredSeq
   (WithOrigin SlotNo) (HeaderState blk') (HeaderState blk')
 -> HeaderStateHistory blk')
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk') (HeaderState blk')
-> HeaderStateHistory blk'
forall a b. (a -> b) -> a -> b
$ (HeaderState blk -> HeaderState blk')
-> (HeaderState blk -> HeaderState blk')
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk') (HeaderState 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 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'
forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderState blk -> HeaderState blk'
castHeaderState AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history

-- | \( O\(n\) \). Rewind the header state history
--
-- 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. (BlockSupportsProtocol blk, HasAnnTip blk)
  => Point blk
  -> HeaderStateHistory blk -> Maybe (HeaderStateHistory blk)
rewind :: Point blk
-> HeaderStateHistory blk -> Maybe (HeaderStateHistory blk)
rewind Point blk
p (HeaderStateHistory AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history) = AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
HeaderStateHistory (AnchoredSeq
   (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
 -> HeaderStateHistory blk)
-> Maybe
     (AnchoredSeq
        (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk))
-> Maybe (HeaderStateHistory blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    WithOrigin SlotNo
-> (Either (HeaderState blk) (HeaderState blk) -> Bool)
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> Maybe
     (AnchoredSeq
        (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk))
forall v a b.
Anchorable v a b =>
v
-> (Either a b -> Bool)
-> AnchoredSeq v a b
-> Maybe (AnchoredSeq v a b)
AS.rollback
      (Point blk -> WithOrigin SlotNo
forall block. 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 (HeaderState blk) (HeaderState blk) -> Point blk)
-> Either (HeaderState blk) (HeaderState blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderState blk -> Point blk)
-> (HeaderState blk -> Point blk)
-> Either (HeaderState blk) (HeaderState blk)
-> Point blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint)
      AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
history

{-------------------------------------------------------------------------------
  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
  -> Ticked (LedgerView (BlockProtocol blk))
  -> Header blk
  -> HeaderStateHistory blk
  -> Except (HeaderError blk) (HeaderStateHistory blk)
validateHeader :: TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
validateHeader TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView Header blk
hdr HeaderStateHistory blk
history = do
    HeaderState blk
st' <- TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
HeaderValidation.validateHeader TopLevelConfig blk
cfg Ticked (LedgerView (BlockProtocol blk))
ledgerView Header blk
hdr Ticked (HeaderState blk)
st
    HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
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
$ HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
forall blk.
HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append HeaderState blk
st' HeaderStateHistory blk
history
  where
    st :: Ticked (HeaderState blk)
    st :: Ticked (HeaderState blk)
st = ConsensusConfig (BlockProtocol blk)
-> Ticked (LedgerView (BlockProtocol blk))
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
ConsensusConfig (BlockProtocol blk)
-> Ticked (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)
           Ticked (LedgerView (BlockProtocol blk))
ledgerView
           (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
           (HeaderStateHistory blk -> HeaderState blk
forall blk. HeaderStateHistory blk -> HeaderState 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 ::
     ApplyBlock (ExtLedgerState blk) blk
  => TopLevelConfig blk
  -> ExtLedgerState blk
     -- ^ Initial ledger state
  -> Chain blk
  -> HeaderStateHistory blk
fromChain :: TopLevelConfig blk
-> ExtLedgerState blk -> Chain blk -> HeaderStateHistory blk
fromChain TopLevelConfig blk
cfg ExtLedgerState blk
initState Chain blk
chain =
    AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
forall blk.
AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
-> HeaderStateHistory blk
HeaderStateHistory (HeaderState blk
-> [HeaderState blk]
-> AnchoredSeq
     (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AS.fromOldestFirst HeaderState blk
anchorSnapshot [HeaderState blk]
snapshots)
  where
    HeaderState blk
anchorSnapshot NE.:| [HeaderState blk]
snapshots =
          (ExtLedgerState blk -> HeaderState blk)
-> NonEmpty (ExtLedgerState blk) -> NonEmpty (HeaderState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState
        (NonEmpty (ExtLedgerState blk) -> NonEmpty (HeaderState blk))
-> (Chain blk -> NonEmpty (ExtLedgerState blk))
-> Chain blk
-> NonEmpty (HeaderState 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 (HeaderState blk))
-> Chain blk -> NonEmpty (HeaderState blk)
forall a b. (a -> b) -> a -> b
$ Chain blk
chain