{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# 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 (..)
  , current
  , trim
  , rewind
  , cast
    -- * Validation
  , validateHeader
    -- * Support for tests
  , fromChain
  ) where

import           Control.Exception (assert)
import           Control.Monad.Except (Except)
import           Data.Coerce (Coercible)
import           Data.Sequence.Strict (StrictSeq ((:|>), Empty))
import qualified Data.Sequence.Strict as Seq
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

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.
data HeaderStateHistory blk = HeaderStateHistory {
      -- | The last, right-most, element in the sequence contains the current
      -- state, see 'headerStateHistoryCurrent'.
      HeaderStateHistory blk -> StrictSeq (HeaderState blk)
headerStateHistorySnapshots :: !(StrictSeq (HeaderState blk))

      -- | Header state /before/ the oldest in 'headerStateHistorySnapshots'.
      -- This is the oldest tip we can roll back to.
    , HeaderStateHistory blk -> HeaderState blk
headerStateHistoryAnchor    :: !(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 HeaderStateHistory {StrictSeq (HeaderState blk)
HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistoryAnchor :: forall blk. HeaderStateHistory blk -> HeaderState blk
headerStateHistorySnapshots :: forall blk. HeaderStateHistory blk -> StrictSeq (HeaderState blk)
..} =
    case StrictSeq (HeaderState blk)
headerStateHistorySnapshots of
      StrictSeq (HeaderState blk)
_ :|> HeaderState blk
cur -> HeaderState blk
cur
      StrictSeq (HeaderState blk)
Empty     -> HeaderState blk
headerStateHistoryAnchor

currentPoint :: HasAnnTip blk => HeaderStateHistory blk -> Point blk
currentPoint :: HeaderStateHistory blk -> Point blk
currentPoint = HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> Point blk)
-> (HeaderStateHistory blk -> HeaderState blk)
-> HeaderStateHistory blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateHistory blk -> HeaderState blk
forall blk. HeaderStateHistory blk -> HeaderState blk
current

-- | Append a 'HeaderState' to the history.
append :: HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append :: HeaderState blk -> HeaderStateHistory blk -> HeaderStateHistory blk
append HeaderState blk
headerState HeaderStateHistory {StrictSeq (HeaderState blk)
HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistoryAnchor :: forall blk. HeaderStateHistory blk -> HeaderState blk
headerStateHistorySnapshots :: forall blk. HeaderStateHistory blk -> StrictSeq (HeaderState blk)
..} =
    HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
        headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistorySnapshots = StrictSeq (HeaderState blk)
headerStateHistorySnapshots StrictSeq (HeaderState blk)
-> HeaderState blk -> StrictSeq (HeaderState blk)
forall a. StrictSeq a -> a -> StrictSeq a
:|> HeaderState blk
headerState
      , headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor    = HeaderState blk
headerStateHistoryAnchor
      }

-- | 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 history :: HeaderStateHistory blk
history@HeaderStateHistory {StrictSeq (HeaderState blk)
HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistoryAnchor :: forall blk. HeaderStateHistory blk -> HeaderState blk
headerStateHistorySnapshots :: forall blk. HeaderStateHistory blk -> StrictSeq (HeaderState blk)
..}
    | Int
toDrop Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
    = HeaderStateHistory blk
history
    | Bool
otherwise
    = case Int
-> StrictSeq (HeaderState blk)
-> (StrictSeq (HeaderState blk), StrictSeq (HeaderState blk))
forall a. Int -> StrictSeq a -> (StrictSeq a, StrictSeq a)
Seq.splitAt Int
toDrop StrictSeq (HeaderState blk)
headerStateHistorySnapshots of
        (StrictSeq (HeaderState blk)
_ :|> HeaderState blk
newAnchor, StrictSeq (HeaderState blk)
trimmed) -> HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
            headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistorySnapshots = StrictSeq (HeaderState blk)
trimmed
          , headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor    = HeaderState blk
newAnchor
          }
        (StrictSeq (HeaderState blk)
Empty, StrictSeq (HeaderState blk)
_) ->
          String -> HeaderStateHistory blk
forall a. HasCallStack => String -> a
error (String -> HeaderStateHistory blk)
-> String -> HeaderStateHistory blk
forall a b. (a -> b) -> a -> b
$ String
"impossible: nothing dropped while toDrop = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
toDrop
  where
    toDrop :: Int
    toDrop :: Int
toDrop = StrictSeq (HeaderState blk) -> Int
forall a. StrictSeq a -> Int
Seq.length StrictSeq (HeaderState blk)
headerStateHistorySnapshots Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n

cast ::
     ( Coercible (ChainDepState (BlockProtocol blk ))
                 (ChainDepState (BlockProtocol blk'))
     , TipInfo blk ~ TipInfo blk'
     )
  => HeaderStateHistory blk -> HeaderStateHistory blk'
cast :: HeaderStateHistory blk -> HeaderStateHistory blk'
cast HeaderStateHistory {StrictSeq (HeaderState blk)
HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistoryAnchor :: forall blk. HeaderStateHistory blk -> HeaderState blk
headerStateHistorySnapshots :: forall blk. HeaderStateHistory blk -> StrictSeq (HeaderState blk)
..} = HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
      headerStateHistorySnapshots :: StrictSeq (HeaderState blk')
headerStateHistorySnapshots = 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')
-> StrictSeq (HeaderState blk) -> StrictSeq (HeaderState blk')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (HeaderState blk)
headerStateHistorySnapshots
    , headerStateHistoryAnchor :: HeaderState blk'
headerStateHistoryAnchor    = 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
$  HeaderState blk
headerStateHistoryAnchor
    }

-- | \( 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 {StrictSeq (HeaderState blk)
HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistoryAnchor :: forall blk. HeaderStateHistory blk -> HeaderState blk
headerStateHistorySnapshots :: forall blk. HeaderStateHistory blk -> StrictSeq (HeaderState blk)
..} =
    case (HeaderState blk -> Bool)
-> StrictSeq (HeaderState blk) -> StrictSeq (HeaderState blk)
forall a. (a -> Bool) -> StrictSeq a -> StrictSeq a
Seq.dropWhileR HeaderState blk -> Bool
rolledBack StrictSeq (HeaderState blk)
headerStateHistorySnapshots of
        StrictSeq (HeaderState blk)
Empty
          | HeaderState blk -> Bool
rolledBack HeaderState blk
headerStateHistoryAnchor
            -- Asked to roll back past the anchor
          -> Bool
-> Maybe (HeaderStateHistory blk) -> Maybe (HeaderStateHistory blk)
forall a. HasCallStack => Bool -> a -> a
assert (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
p WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<=
                     Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot (HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint HeaderState blk
headerStateHistoryAnchor))
             Maybe (HeaderStateHistory blk)
forall a. Maybe a
Nothing

        StrictSeq (HeaderState blk)
headerStateHistorySnapshots'
          | let history' :: HeaderStateHistory blk
history' = HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
                     headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistorySnapshots = StrictSeq (HeaderState blk)
headerStateHistorySnapshots'
                   , HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor
                   }
          -> Bool
-> Maybe (HeaderStateHistory blk) -> Maybe (HeaderStateHistory blk)
forall a. HasCallStack => Bool -> a -> a
assert (HeaderStateHistory blk -> Point blk
forall blk. HasAnnTip blk => HeaderStateHistory blk -> Point blk
currentPoint HeaderStateHistory blk
history' Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
p) (Maybe (HeaderStateHistory blk) -> Maybe (HeaderStateHistory blk))
-> Maybe (HeaderStateHistory blk) -> Maybe (HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$
             HeaderStateHistory blk -> Maybe (HeaderStateHistory blk)
forall a. a -> Maybe a
Just HeaderStateHistory blk
history'
  where
    -- | Should the given 'HeaderState' be rolled back?
    rolledBack :: HeaderState blk -> Bool
    rolledBack :: HeaderState blk -> Bool
rolledBack HeaderState blk
headerState = HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint HeaderState blk
headerState Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk
p

{-------------------------------------------------------------------------------
  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 = HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
      headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistorySnapshots = [HeaderState blk] -> StrictSeq (HeaderState blk)
forall a. [a] -> StrictSeq a
Seq.fromList [HeaderState blk]
snapshots
    , headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor    = HeaderState blk
anchor
    }
  where
    HeaderState blk
anchor 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