{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}

-- | Intended to be imported qualified.
--
module Ouroboros.Network.InboundGovernor.ControlChannel
  ( NewConnection (..)
  , ControlChannel (..)
  , ServerControlChannel
  , newControlChannel
  , newOutboundConnection
  , newInboundConnection
  ) where

import           Control.Monad.Class.MonadSTM.Strict

import           Data.Functor (($>))

import           Network.Mux.Types (MuxMode)

import           Ouroboros.Network.ConnectionHandler
import           Ouroboros.Network.ConnectionId (ConnectionId (..))
import           Ouroboros.Network.ConnectionManager.Types


-- | Announcment message for a new connection.
--
data NewConnection peerAddr handle

    -- | Announce a new connection.  /Inbound protocol governor/ will start
    -- responder protocols using 'StartOnDemand' strategy and monitor remote
    -- transitions: @PromotedToWarm^{Duplex}_{Remote}@ and
    -- @DemotedToCold^{dataFlow}_{Remote}@.
    = NewConnection
      !Provenance
      !(ConnectionId peerAddr)
      !DataFlow
      !handle

instance Show peerAddr
      => Show (NewConnection peerAddr handle) where
      show :: NewConnection peerAddr handle -> String
show (NewConnection Provenance
provenance ConnectionId peerAddr
connId DataFlow
dataFlow handle
_) =
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"NewConnection "
               , Provenance -> String
forall a. Show a => a -> String
show Provenance
provenance
               , String
" "
               , ConnectionId peerAddr -> String
forall a. Show a => a -> String
show ConnectionId peerAddr
connId
               , String
" "
               , DataFlow -> String
forall a. Show a => a -> String
show DataFlow
dataFlow
               ]



-- | Server control channel.  It allows to pass 'STM' transactions which will
-- resolve to 'NewConnection'.   Server's monitoring thread is the consumer
-- of this messages; there are two produceres: accept loop and connection
-- handler for outbound connections.
--
data ControlChannel m msg =
  ControlChannel {
    -- | Read a single 'NewConnection' instructrion from the channel.
    --
    ControlChannel m msg -> STM m msg
readMessage  :: STM m msg,

    -- | Write a 'NewConnection' to the channel.
    --
    ControlChannel m msg -> msg -> STM m ()
writeMessage :: msg -> STM m ()
  }


type ServerControlChannel (muxMode :: MuxMode) peerAddr bytes m a b =
    ControlChannel m (NewConnection peerAddr (Handle muxMode peerAddr bytes m a b))


newControlChannel :: forall m srvCntrlMsg.
                     MonadLabelledSTM m
                  => m (ControlChannel m srvCntrlMsg)
newControlChannel :: m (ControlChannel m srvCntrlMsg)
newControlChannel = do
    -- Queue size: events will come eihter from the accept loop or from the
    -- connection manager (when it included an outbound duplex connection).
    TBQueue m srvCntrlMsg
channel <-
      STM m (TBQueue m srvCntrlMsg) -> m (TBQueue m srvCntrlMsg)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TBQueue m srvCntrlMsg) -> m (TBQueue m srvCntrlMsg))
-> STM m (TBQueue m srvCntrlMsg) -> m (TBQueue m srvCntrlMsg)
forall a b. (a -> b) -> a -> b
$
        Natural -> STM m (TBQueue m srvCntrlMsg)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueue m a)
newTBQueue Natural
10
        STM m (TBQueue m srvCntrlMsg)
-> (TBQueue m srvCntrlMsg -> STM m (TBQueue m srvCntrlMsg))
-> STM m (TBQueue m srvCntrlMsg)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TBQueue m srvCntrlMsg
q -> TBQueue m srvCntrlMsg -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TBQueue m a -> String -> STM m ()
labelTBQueue TBQueue m srvCntrlMsg
q String
"server-cc" STM m () -> TBQueue m srvCntrlMsg -> STM m (TBQueue m srvCntrlMsg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TBQueue m srvCntrlMsg
q
    ControlChannel m srvCntrlMsg -> m (ControlChannel m srvCntrlMsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlChannel m srvCntrlMsg -> m (ControlChannel m srvCntrlMsg))
-> ControlChannel m srvCntrlMsg -> m (ControlChannel m srvCntrlMsg)
forall a b. (a -> b) -> a -> b
$ ControlChannel :: forall (m :: * -> *) msg.
STM m msg -> (msg -> STM m ()) -> ControlChannel m msg
ControlChannel {
        readMessage :: STM m srvCntrlMsg
readMessage  = TBQueue m srvCntrlMsg -> STM m srvCntrlMsg
readMessage TBQueue m srvCntrlMsg
channel,
        writeMessage :: srvCntrlMsg -> STM m ()
writeMessage = TBQueue m srvCntrlMsg -> srvCntrlMsg -> STM m ()
writeMessage TBQueue m srvCntrlMsg
channel
      }
  where
    readMessage
      :: TBQueue m srvCntrlMsg
      -> STM     m srvCntrlMsg
    readMessage :: TBQueue m srvCntrlMsg -> STM m srvCntrlMsg
readMessage = TBQueue m srvCntrlMsg -> STM m srvCntrlMsg
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m a
readTBQueue

    writeMessage
      :: TBQueue m srvCntrlMsg
      -> srvCntrlMsg
      -> STM m ()
    writeMessage :: TBQueue m srvCntrlMsg -> srvCntrlMsg -> STM m ()
writeMessage TBQueue m srvCntrlMsg
q srvCntrlMsg
a = TBQueue m srvCntrlMsg -> srvCntrlMsg -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> a -> STM m ()
writeTBQueue TBQueue m srvCntrlMsg
q srvCntrlMsg
a


newOutboundConnection
    :: ControlChannel m (NewConnection peerAddr handle)
    -> ConnectionId peerAddr
    -> DataFlow
    -> handle
    -> STM m ()
newOutboundConnection :: ControlChannel m (NewConnection peerAddr handle)
-> ConnectionId peerAddr -> DataFlow -> handle -> STM m ()
newOutboundConnection ControlChannel m (NewConnection peerAddr handle)
channel ConnectionId peerAddr
connId DataFlow
dataFlow handle
handle =
    ControlChannel m (NewConnection peerAddr handle)
-> NewConnection peerAddr handle -> STM m ()
forall (m :: * -> *) msg. ControlChannel m msg -> msg -> STM m ()
writeMessage ControlChannel m (NewConnection peerAddr handle)
channel
                (Provenance
-> ConnectionId peerAddr
-> DataFlow
-> handle
-> NewConnection peerAddr handle
forall peerAddr handle.
Provenance
-> ConnectionId peerAddr
-> DataFlow
-> handle
-> NewConnection peerAddr handle
NewConnection Provenance
Outbound ConnectionId peerAddr
connId DataFlow
dataFlow handle
handle)

newInboundConnection
    :: ControlChannel m (NewConnection peerAddr handle)
    -> ConnectionId peerAddr
    -> DataFlow
    -> handle
    -> STM m ()
newInboundConnection :: ControlChannel m (NewConnection peerAddr handle)
-> ConnectionId peerAddr -> DataFlow -> handle -> STM m ()
newInboundConnection ControlChannel m (NewConnection peerAddr handle)
channel ConnectionId peerAddr
connId DataFlow
dataFlow handle
handle =
    ControlChannel m (NewConnection peerAddr handle)
-> NewConnection peerAddr handle -> STM m ()
forall (m :: * -> *) msg. ControlChannel m msg -> msg -> STM m ()
writeMessage ControlChannel m (NewConnection peerAddr handle)
channel
                 (Provenance
-> ConnectionId peerAddr
-> DataFlow
-> handle
-> NewConnection peerAddr handle
forall peerAddr handle.
Provenance
-> ConnectionId peerAddr
-> DataFlow
-> handle
-> NewConnection peerAddr handle
NewConnection Provenance
Inbound ConnectionId peerAddr
connId DataFlow
dataFlow handle
handle)