{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

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.Proxy (Proxy (..))
import Ouroboros.Consensus.Block
  ( BlockProtocol
  , BlockSupportsProtocol
  , Header
  , SlotNo
  , WithOrigin (..)
  , blockSlot
  )
import Ouroboros.Consensus.Config (TopLevelConfig)
import Ouroboros.Consensus.HardFork.Combinator.Abstract
  ( ImmutableEraParams
  , immutableEpochInfo
  )
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
import Ouroboros.Consensus.Leios.Protocol (trivialLeiosLedgerView)
import Ouroboros.Consensus.Protocol.Abstract (LedgerView)
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 ::
  ( ImmutableEraParams blk
  , BlockSupportsProtocol blk
  , LedgerView (BlockProtocol blk) ~ ()
  ) =>
  TopLevelConfig blk ->
  AnchoredFragment (Header blk) ->
  AnchoredFragment (HeaderWithTime blk)
attachSlotTimeToFragment :: forall blk.
(ImmutableEraParams blk, BlockSupportsProtocol blk,
 LedgerView (BlockProtocol blk) ~ ()) =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
attachSlotTimeToFragment TopLevelConfig blk
cfg AnchoredFragment (Header blk)
frag =
  Anchor (HeaderWithTime blk)
-> [HeaderWithTime blk]
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst (Anchor (Header blk) -> Anchor (HeaderWithTime blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
frag)) ([HeaderWithTime blk]
 -> AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk))
-> [HeaderWithTime blk]
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$
    (WithOrigin SlotNo -> Header blk -> HeaderWithTime blk)
-> [WithOrigin SlotNo] -> [Header blk] -> [HeaderWithTime blk]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TopLevelConfig blk
-> WithOrigin SlotNo -> Header blk -> HeaderWithTime blk
forall blk.
(ImmutableEraParams blk, BlockSupportsProtocol blk,
 LedgerView (BlockProtocol blk) ~ ()) =>
TopLevelConfig blk
-> WithOrigin SlotNo -> Header blk -> HeaderWithTime blk
attachSlotTime TopLevelConfig blk
cfg) [WithOrigin SlotNo]
predecessorSlots [Header blk]
hdrs
 where
  hdrs :: [Header blk]
hdrs = AnchoredFragment (Header blk) -> [Header blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment (Header blk)
frag

  predecessorSlots :: [WithOrigin SlotNo]
predecessorSlots =
    Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
frag) WithOrigin SlotNo -> [WithOrigin SlotNo] -> [WithOrigin SlotNo]
forall a. a -> [a] -> [a]
: (Header blk -> WithOrigin SlotNo)
-> [Header blk] -> [WithOrigin SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (SlotNo -> WithOrigin SlotNo)
-> (Header blk -> SlotNo) -> Header blk -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) [Header blk]
hdrs

-- | For a block whose ledger view is trivial, and so is the same at every slot
attachSlotTime ::
  forall blk.
  ( ImmutableEraParams blk
  , BlockSupportsProtocol blk
  , LedgerView (BlockProtocol blk) ~ ()
  ) =>
  TopLevelConfig blk ->
  -- | The slot of the header's predecessor
  WithOrigin SlotNo ->
  Header blk ->
  HeaderWithTime blk
attachSlotTime :: forall blk.
(ImmutableEraParams blk, BlockSupportsProtocol blk,
 LedgerView (BlockProtocol blk) ~ ()) =>
TopLevelConfig blk
-> WithOrigin SlotNo -> Header blk -> HeaderWithTime blk
attachSlotTime TopLevelConfig blk
cfg WithOrigin SlotNo
predecessorSlot 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)
    , hwtPredecessorSlot :: WithOrigin SlotNo
hwtPredecessorSlot = WithOrigin SlotNo
predecessorSlot
    , hwtLeiosLedgerView :: StrictMaybe LeiosLedgerView
hwtLeiosLedgerView = Proxy blk -> StrictMaybe LeiosLedgerView
forall blk (proxy :: * -> *).
(LeiosProtocol (BlockProtocol blk),
 LedgerView (BlockProtocol blk) ~ ()) =>
proxy blk -> StrictMaybe LeiosLedgerView
trivialLeiosLedgerView (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
    }
 where
  ei :: EpochInfo Identity
ei = TopLevelConfig blk -> EpochInfo Identity
forall (m :: * -> *) blk.
(Monad m, ImmutableEraParams blk) =>
TopLevelConfig blk -> EpochInfo m
immutableEpochInfo TopLevelConfig blk
cfg