{-# LANGUAGE BangPatterns   #-}
{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes     #-}

module Ouroboros.Network.InboundGovernor.InformationChannel
  ( InformationChannel (..)
  , newInformationChannel
  ) where

import Control.Concurrent.Class.MonadSTM.Strict

import Data.Functor (($>))
import GHC.Natural (Natural)

-- | Information channel.
--
data InformationChannel a m =
  InformationChannel {
    -- | Read a single value from the channel.
    --
    forall a (m :: * -> *). InformationChannel a m -> STM m a
readMessage  :: STM m a,

    -- | Efficiently flush all values from the channel
    -- for batch processing
    --
    forall a (m :: * -> *). InformationChannel a m -> STM m [a]
readMessages :: STM m [a],

    -- | Write a value to the channel.
    --
    forall a (m :: * -> *). InformationChannel a m -> a -> STM m ()
writeMessage :: a -> STM m ()
  }


-- | Create a new 'InformationChannel' backed by a `TBQueue`.
--
newInformationChannel :: forall a m. MonadLabelledSTM m
                      => m (InformationChannel a m)
newInformationChannel :: forall a (m :: * -> *).
MonadLabelledSTM m =>
m (InformationChannel a m)
newInformationChannel = do
    channel <-
      STM m (StrictTBQueue m a) -> m (StrictTBQueue m a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTBQueue m a) -> m (StrictTBQueue m a))
-> STM m (StrictTBQueue m a) -> m (StrictTBQueue m a)
forall a b. (a -> b) -> a -> b
$
        Natural -> STM m (StrictTBQueue m a)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (StrictTBQueue m a)
newTBQueue Natural
cc_QUEUE_BOUND
        STM m (StrictTBQueue m a)
-> (StrictTBQueue m a -> STM m (StrictTBQueue m a))
-> STM m (StrictTBQueue m a)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \StrictTBQueue m a
q -> StrictTBQueue m a -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTBQueue m a -> String -> STM m ()
labelTBQueue StrictTBQueue m a
q String
"server-cc" STM m () -> StrictTBQueue m a -> STM m (StrictTBQueue m a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StrictTBQueue m a
q
    pure $ InformationChannel {
        readMessage  = readTBQueue channel,
        readMessages = flushTBQueue channel,
        writeMessage = \(!a
a) -> StrictTBQueue m a -> a -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> a -> STM m ()
writeTBQueue StrictTBQueue m a
channel a
a
      }


-- | The 'InformationChannel's 'TBQueue' depth.
--
cc_QUEUE_BOUND :: Natural
cc_QUEUE_BOUND :: Natural
cc_QUEUE_BOUND = Natural
100