{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}

-- | The announcements the node has accepted, from whichever peer.
--
-- Each LeiosNotify client already holds its own upstream peer to at most two
-- announcements per election. But the node relays what it accepts from all its
-- peers, and a downstream peer holds the node to the same: no repeat, and no
-- third announcement of an election. So the node decides once, here, whether
-- an announcement is new, and only then relays it.
module Ouroboros.Consensus.Leios.AnnounceState
  ( AnnounceState
  , hasAnnouncement
  , newAnnounceState
  , onValidAnnouncement
  , pruneAnnounceState
  ) where

import Control.Monad (when)
import Data.Void (Void)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block (ConvertRawHash, GetHeader, HasHeader, Header, SlotNo)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (addRelTime)
import Ouroboros.Consensus.Leios.NotifyLog
  ( Notification (..)
  , NotifyLog
  , appendNotifyLog
  )
import Ouroboros.Consensus.Leios.Protocol (OCINStaleness (FreshOCIN))
import Ouroboros.Consensus.Leios.Types (ElectionId (electionSlot), RankingBlockHash)
import qualified Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements as Announcements
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements.Validation
  ( AnnouncingHeader (..)
  , ValidAnnouncement (..)
  , announcingRbHash
  , maxAnnouncementAgeSend
  )
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , STM
  , StrictTVar
  , modifyTVar
  , newTVarIO
  , readTVar
  , writeTVar
  )

-- | The node's announcements, per election, and the log it relays them in.
data AnnounceState m blk = MkAnnounceState
  { forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
announced :: !(StrictTVar m (Announcements.State (AnnouncingHeader blk)))
  , forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m SlotNo
prunedTo :: !(StrictTVar m SlotNo)
  -- ^ every election before this slot is forgotten, and ignored
  , forall (m :: * -> *) blk. AnnounceState m blk -> NotifyLog m blk
relayLog :: !(NotifyLog m blk)
  }

newAnnounceState ::
  (IOLike m, NoThunks (Header blk)) =>
  NotifyLog m blk ->
  m (AnnounceState m blk)
newAnnounceState :: forall (m :: * -> *) blk.
(IOLike m, NoThunks (Header blk)) =>
NotifyLog m blk -> m (AnnounceState m blk)
newAnnounceState NotifyLog m blk
notifyLog =
  StrictTVar m (State (AnnouncingHeader blk))
-> StrictTVar m SlotNo -> NotifyLog m blk -> AnnounceState m blk
forall (m :: * -> *) blk.
StrictTVar m (State (AnnouncingHeader blk))
-> StrictTVar m SlotNo -> NotifyLog m blk -> AnnounceState m blk
MkAnnounceState (StrictTVar m (State (AnnouncingHeader blk))
 -> StrictTVar m SlotNo -> NotifyLog m blk -> AnnounceState m blk)
-> m (StrictTVar m (State (AnnouncingHeader blk)))
-> m (StrictTVar m SlotNo
      -> NotifyLog m blk -> AnnounceState m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State (AnnouncingHeader blk)
-> m (StrictTVar m (State (AnnouncingHeader blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO State (AnnouncingHeader blk)
forall anc. State anc
Announcements.empty m (StrictTVar m SlotNo -> NotifyLog m blk -> AnnounceState m blk)
-> m (StrictTVar m SlotNo)
-> m (NotifyLog m blk -> AnnounceState m blk)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SlotNo -> m (StrictTVar m SlotNo)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO SlotNo
0 m (NotifyLog m blk -> AnnounceState m blk)
-> m (NotifyLog m blk) -> m (AnnounceState m blk)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NotifyLog m blk -> m (NotifyLog m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NotifyLog m blk
notifyLog

-- | Accept a valid announcement, and relay it if it is new and fresh enough,
-- until 'maxAnnouncementAgeSend' after its election slot began.
--
-- An announcement signed by a revoked operational certificate is neither, and
-- one of an election already pruned, while it was validated, is not new.
onValidAnnouncement ::
  (IOLike m, HasHeader (Header blk)) =>
  AnnounceState m blk ->
  ValidAnnouncement blk ->
  STM m ()
onValidAnnouncement :: forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
AnnounceState m blk -> ValidAnnouncement blk -> STM m ()
onValidAnnouncement AnnounceState m blk
st ValidAnnouncement blk
valid = do
  pruned <- StrictTVar m SlotNo -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m SlotNo
prunedTo
  when (announcementStaleness == FreshOCIN && electionSlot electionId >= pruned) $ do
    seen <- readTVar announced
    case Announcements.insert @_ @Void electionId announcingHeader seen of
      Left Error Void
_repeatedOrThird -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right State (AnnouncingHeader blk)
seen' -> do
        StrictTVar m (State (AnnouncingHeader blk))
-> State (AnnouncingHeader blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (State (AnnouncingHeader blk))
announced State (AnnouncingHeader blk)
seen'
        Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
announcementAge NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
maxAnnouncementAgeSend) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
          NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
forall (m :: * -> *) blk.
IOLike m =>
NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
appendNotifyLog
            NotifyLog m blk
relayLog
            (AnnouncingHeader blk -> Notification blk
forall blk. AnnouncingHeader blk -> Notification blk
NotifyAnnouncement AnnouncingHeader blk
announcingHeader)
            (NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime NominalDiffTime
maxAnnouncementAgeSend RelativeTime
announcementOnset)
 where
  electionId :: ElectionId
electionId = AnnouncingHeader blk -> ElectionId
forall blk. AnnouncingHeader blk -> ElectionId
ancElectionId AnnouncingHeader blk
announcingHeader

  MkAnnounceState{StrictTVar m SlotNo
prunedTo :: forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m SlotNo
prunedTo :: StrictTVar m SlotNo
prunedTo, StrictTVar m (State (AnnouncingHeader blk))
announced :: forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
announced :: StrictTVar m (State (AnnouncingHeader blk))
announced, NotifyLog m blk
relayLog :: forall (m :: * -> *) blk. AnnounceState m blk -> NotifyLog m blk
relayLog :: NotifyLog m blk
relayLog} = AnnounceState m blk
st

  MkValidAnnouncement
    { AnnouncingHeader blk
announcingHeader :: AnnouncingHeader blk
announcingHeader :: forall blk. ValidAnnouncement blk -> AnnouncingHeader blk
announcingHeader
    , RelativeTime
announcementOnset :: RelativeTime
announcementOnset :: forall blk. ValidAnnouncement blk -> RelativeTime
announcementOnset
    , NominalDiffTime
announcementAge :: NominalDiffTime
announcementAge :: forall blk. ValidAnnouncement blk -> NominalDiffTime
announcementAge
    , OCINStaleness
announcementStaleness :: OCINStaleness
announcementStaleness :: forall blk. ValidAnnouncement blk -> OCINStaleness
announcementStaleness
    } = ValidAnnouncement blk
valid

-- | Whether the node accepted the announcement of this announcing block, in an
-- election of the given slot, so that it can relay votes for it.
--
-- It accepts but does not relay one too old to relay, but then the votes for
-- it are past their deadline too, so the node relays none of them either.
hasAnnouncement ::
  (IOLike m, ConvertRawHash blk, GetHeader blk) =>
  AnnounceState m blk ->
  SlotNo ->
  RankingBlockHash ->
  STM m Bool
hasAnnouncement :: forall (m :: * -> *) blk.
(IOLike m, ConvertRawHash blk, GetHeader blk) =>
AnnounceState m blk -> SlotNo -> RankingBlockHash -> STM m Bool
hasAnnouncement AnnounceState m blk
st SlotNo
slot RankingBlockHash
rbHash =
  (AnnouncingHeader blk -> Bool) -> [AnnouncingHeader blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RankingBlockHash -> RankingBlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== RankingBlockHash
rbHash) (RankingBlockHash -> Bool)
-> (AnnouncingHeader blk -> RankingBlockHash)
-> AnnouncingHeader blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnouncingHeader blk -> RankingBlockHash
forall blk.
(ConvertRawHash blk, GetHeader blk) =>
AnnouncingHeader blk -> RankingBlockHash
announcingRbHash) ([AnnouncingHeader blk] -> Bool)
-> (State (AnnouncingHeader blk) -> [AnnouncingHeader blk])
-> State (AnnouncingHeader blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> State (AnnouncingHeader blk) -> [AnnouncingHeader blk]
forall anc. SlotNo -> State anc -> [anc]
Announcements.inSlot SlotNo
slot (State (AnnouncingHeader blk) -> Bool)
-> STM m (State (AnnouncingHeader blk)) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (State (AnnouncingHeader blk))
-> STM m (State (AnnouncingHeader blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
announced AnnounceState m blk
st)

-- | Forget every election before the given slot, which is the immutable tip's.
pruneAnnounceState ::
  IOLike m =>
  AnnounceState m blk ->
  SlotNo ->
  STM m ()
pruneAnnounceState :: forall (m :: * -> *) blk.
IOLike m =>
AnnounceState m blk -> SlotNo -> STM m ()
pruneAnnounceState AnnounceState m blk
st SlotNo
immTipSlot = do
  StrictTVar m (State (AnnouncingHeader blk))
-> (State (AnnouncingHeader blk) -> State (AnnouncingHeader blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m (State (AnnouncingHeader blk))
announced AnnounceState m blk
st) (([AnnouncingHeader blk], State (AnnouncingHeader blk))
-> State (AnnouncingHeader blk)
forall a b. (a, b) -> b
snd (([AnnouncingHeader blk], State (AnnouncingHeader blk))
 -> State (AnnouncingHeader blk))
-> (State (AnnouncingHeader blk)
    -> ([AnnouncingHeader blk], State (AnnouncingHeader blk)))
-> State (AnnouncingHeader blk)
-> State (AnnouncingHeader blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo
-> State (AnnouncingHeader blk)
-> ([AnnouncingHeader blk], State (AnnouncingHeader blk))
forall anc. SlotNo -> State anc -> ([anc], State anc)
Announcements.prune SlotNo
immTipSlot)
  StrictTVar m SlotNo -> SlotNo -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (AnnounceState m blk -> StrictTVar m SlotNo
forall (m :: * -> *) blk.
AnnounceState m blk -> StrictTVar m SlotNo
prunedTo AnnounceState m blk
st) SlotNo
immTipSlot