{-# LANGUAGE FlexibleContexts #-}

module Test.Util.Header
  ( -- * Enriching headers with a relative slot time
    attachSlotTime
  , attachSlotTimeToFragment
  , dropTimeFromFragment
  ) where

import Cardano.Slotting.EpochInfo.API (epochInfoSlotToRelativeTime)
import Data.Functor.Identity (runIdentity)
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block (Header, blockSlot)
import Ouroboros.Consensus.Config (TopLevelConfig)
import Ouroboros.Consensus.HardFork.Combinator.Abstract
  ( ImmutableEraParams
  , immutableEpochInfo
  )
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF

{-------------------------------------------------------------------------------
  Enriching headers with a relative slot time
-------------------------------------------------------------------------------}

dropTimeFromFragment ::
  AF.HasHeader (Header blk) =>
  AnchoredFragment (HeaderWithTime blk) ->
  AnchoredFragment (Header blk)
dropTimeFromFragment :: forall blk.
HasHeader (Header blk) =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (Header blk)
dropTimeFromFragment = (HeaderWithTime blk -> Header blk)
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (Header blk)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader

attachSlotTimeToFragment ::
  ( AF.HasHeader (Header blk)
  , Typeable blk
  , ImmutableEraParams blk
  ) =>
  TopLevelConfig blk ->
  AnchoredFragment (Header blk) ->
  AnchoredFragment (HeaderWithTime blk)
attachSlotTimeToFragment :: forall blk.
(HasHeader (Header blk), Typeable blk, ImmutableEraParams blk) =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
attachSlotTimeToFragment TopLevelConfig blk
cfg = (Header blk -> HeaderWithTime blk)
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment (TopLevelConfig blk -> Header blk -> HeaderWithTime blk
forall blk.
(HasHeader (Header blk), ImmutableEraParams blk) =>
TopLevelConfig blk -> Header blk -> HeaderWithTime blk
attachSlotTime TopLevelConfig blk
cfg)

attachSlotTime ::
  (AF.HasHeader (Header blk), ImmutableEraParams blk) =>
  TopLevelConfig blk ->
  Header blk ->
  HeaderWithTime blk
attachSlotTime :: forall blk.
(HasHeader (Header blk), ImmutableEraParams blk) =>
TopLevelConfig blk -> Header blk -> HeaderWithTime blk
attachSlotTime TopLevelConfig blk
cfg Header blk
hdr =
  HeaderWithTime
    { hwtHeader :: Header blk
hwtHeader = Header blk
hdr
    , hwtSlotRelativeTime :: RelativeTime
hwtSlotRelativeTime =
        Identity RelativeTime -> RelativeTime
forall a. Identity a -> a
runIdentity (Identity RelativeTime -> RelativeTime)
-> Identity RelativeTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$ EpochInfo Identity -> SlotNo -> Identity RelativeTime
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime EpochInfo Identity
ei (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
    }
 where
  ei :: EpochInfo Identity
ei = TopLevelConfig blk -> EpochInfo Identity
forall (m :: * -> *) blk.
(Monad m, ImmutableEraParams blk) =>
TopLevelConfig blk -> EpochInfo m
immutableEpochInfo TopLevelConfig blk
cfg