{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- Internals of inbound protocol governor.  This module provide 'Event' type,
-- which enumerates external events and stm action which block until these
-- events fire.
--
module Ouroboros.Network.InboundGovernor.Event
  ( Event (..)
  , EventSignal
  , firstMuxToFinish
  , Terminated (..)
  , firstMiniProtocolToFinish
  , firstPeerPromotedToWarm
  , firstPeerPromotedToHot
  , firstPeerDemotedToWarm
  , firstPeerDemotedToCold
  , firstPeerCommitRemote
  ) where

import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow hiding (handle)

import           Data.ByteString.Lazy (ByteString)
import           Data.Functor (($>))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Monoid.Synchronisation
import qualified Data.Set as Set

import qualified Network.Mux as Mux
import           Network.Mux.Types (MiniProtocolDir (..),
                     MiniProtocolStatus (..))

import           Ouroboros.Network.ConnectionHandler
import           Ouroboros.Network.ConnectionId (ConnectionId (..))
import           Ouroboros.Network.ConnectionManager.Types
import qualified Ouroboros.Network.InboundGovernor.ControlChannel as ControlChannel
import           Ouroboros.Network.InboundGovernor.State
import           Ouroboros.Network.Mux hiding (ControlMessage)


-- | Edge triggered events to which the /inbound protocol governor/ reacts.
--
data Event (muxMode :: MuxMode) peerAddr m a b
    -- | A request to start mini-protocol bundle, either from the server or from
    -- connection manager after a duplex connection was negotiated.
    --
    = NewConnection !(ControlChannel.NewConnection peerAddr
                        (Handle muxMode peerAddr ByteString m a b))

    -- | A multiplexer exited.
    --
    | MuxFinished            !(ConnectionId peerAddr) !(Maybe SomeException)

    -- | A mini-protocol terminated either cleanly or abruptly.
    --
    | MiniProtocolTerminated !(Terminated muxMode peerAddr m a b)

    -- | Transition from 'RemoteEstablished' to 'RemoteIdle'.
    --
    | WaitIdleRemote         !(ConnectionId peerAddr)

    -- | A remote @warm → hot@ transition.  It is scheduled as soon as all hot
    -- mini-protocols are running.
    --
    | RemotePromotedToHot    !(ConnectionId peerAddr)

    -- | A @hot → warm@ transition.  It is scheduled as soon as any hot
    -- mini-protocol terminates.
    --
    | RemoteDemotedToWarm    !(ConnectionId peerAddr)

    -- | Transition from 'RemoteIdle' to 'RemoteCold'.
    --
    | CommitRemote           !(ConnectionId peerAddr)

    -- | Transition from 'RemoteIdle' or 'RemoteCold' to 'RemoteEstablished'.
    --
    | AwakeRemote            !(ConnectionId peerAddr)


--
-- STM transactions which detect 'Event's (signals)
--


-- | A signal which returns an 'Event'.  Signals are combined together and
-- passed used to fold the current state map.
--
type EventSignal (muxMode :: MuxMode) peerAddr m a b =
        ConnectionId peerAddr
     -> ConnectionState muxMode peerAddr m a b
     -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)

-- | A mux stopped.  If mux exited cleanly no error is attached.
--
firstMuxToFinish :: MonadSTM m
                 => EventSignal muxMode peerAddr m a b
firstMuxToFinish :: EventSignal muxMode peerAddr m a b
firstMuxToFinish ConnectionId peerAddr
connId ConnectionState { Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux :: Mux muxMode m
csMux } =
    STM m (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m (Event muxMode peerAddr m a b)
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> STM m (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr
-> Maybe SomeException -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr
-> Maybe SomeException -> Event muxMode peerAddr m a b
MuxFinished ConnectionId peerAddr
connId (Maybe SomeException -> Event muxMode peerAddr m a b)
-> STM m (Maybe SomeException)
-> STM m (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mux muxMode m -> STM m (Maybe SomeException)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m -> STM m (Maybe SomeException)
Mux.muxStopped Mux muxMode m
csMux


-- | When a mini-protocol terminates we take 'Terminated' out of 'ConnectionState
-- and pass it to the main loop.  This is just enough to decide if we need to
-- restart a mini-protocol and to do the restart.
--
data Terminated muxMode peerAddr m a b = Terminated {
    Terminated muxMode peerAddr m a b -> ConnectionId peerAddr
tConnId           :: !(ConnectionId peerAddr),
    Terminated muxMode peerAddr m a b -> Mux muxMode m
tMux              :: !(Mux.Mux muxMode m),
    Terminated muxMode peerAddr m a b -> MiniProtocolData muxMode m a b
tMiniProtocolData :: !(MiniProtocolData muxMode m a b),
    Terminated muxMode peerAddr m a b -> DataFlow
tDataFlow         :: !DataFlow,
    Terminated muxMode peerAddr m a b -> Either SomeException b
tResult           :: !(Either SomeException b)
  }


-- | Detect when one of the mini-protocols terminated.
--
-- /triggers:/ 'MiniProtocolTerminated'.
--
firstMiniProtocolToFinish :: MonadSTM m
                          => EventSignal muxMode peerAddr m a b
firstMiniProtocolToFinish :: EventSignal muxMode peerAddr m a b
firstMiniProtocolToFinish
    ConnectionId peerAddr
connId
    ConnectionState { Mux muxMode m
csMux :: Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux,
                      Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap,
                      DataFlow
csDataFlow :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> DataFlow
csDataFlow :: DataFlow
csDataFlow,
                      Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b
-> Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap :: Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap
                    }
    = (MiniProtocolNum
 -> STM m (Either SomeException b)
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> Map MiniProtocolNum (STM m (Either SomeException b))
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
        (\MiniProtocolNum
miniProtocolNum STM m (Either SomeException b)
completionAction ->
              (\Either SomeException b
tResult -> Terminated muxMode peerAddr m a b -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
Terminated muxMode peerAddr m a b -> Event muxMode peerAddr m a b
MiniProtocolTerminated (Terminated muxMode peerAddr m a b -> Event muxMode peerAddr m a b)
-> Terminated muxMode peerAddr m a b
-> Event muxMode peerAddr m a b
forall a b. (a -> b) -> a -> b
$ Terminated :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr
-> Mux muxMode m
-> MiniProtocolData muxMode m a b
-> DataFlow
-> Either SomeException b
-> Terminated muxMode peerAddr m a b
Terminated {
                    tConnId :: ConnectionId peerAddr
tConnId           = ConnectionId peerAddr
connId,
                    tMux :: Mux muxMode m
tMux              = Mux muxMode m
csMux,
                    tMiniProtocolData :: MiniProtocolData muxMode m a b
tMiniProtocolData = Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> MiniProtocolNum -> MiniProtocolData muxMode m a b
forall k a. Ord k => Map k a -> k -> a
Map.! MiniProtocolNum
miniProtocolNum,
                    tDataFlow :: DataFlow
tDataFlow         = DataFlow
csDataFlow,
                    Either SomeException b
tResult :: Either SomeException b
tResult :: Either SomeException b
tResult
                  }
              )
          (Either SomeException b -> Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Either SomeException b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Either SomeException b)
-> FirstToFinish (STM m) (Either SomeException b)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish STM m (Either SomeException b)
completionAction
        )
        Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap


-- | Detect when one of the peers was promoted to warm, e.g.
-- @PromotedToWarm^{Duplex}_{Remote}@ or
-- @PromotedToWarm^{Unidirectional}_{Remote}@.
--
-- /triggers:/ 'PromotedToWarm'
--
-- Note: The specification only describes @PromotedToWarm^{Duplex}_{Remote}@
-- transition, but here we don't make a distinction on @Duplex@ and
-- @Unidirectional@ connections.
--
firstPeerPromotedToWarm :: forall muxMode peerAddr m a b.
                           MonadSTM m
                        => EventSignal muxMode peerAddr m a b
firstPeerPromotedToWarm :: EventSignal muxMode peerAddr m a b
firstPeerPromotedToWarm
    ConnectionId peerAddr
connId
    ConnectionState { Mux muxMode m
csMux :: Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux, RemoteState m
csRemoteState :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> RemoteState m
csRemoteState :: RemoteState m
csRemoteState }
    = case RemoteState m
csRemoteState of
        -- the connection is already in 'RemoteEstablished' state.
        RemoteState m
RemoteEstablished -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty

        -- If the connection is in 'RemoteCold' state we do first to finish
        -- synchronisation to detect incoming traffic on any of the responder
        -- mini-protocols.
        --
        -- This works for both duplex and unidirectional connections (e.g. p2p
        -- \/ non-p2p nodes), for which protocols are started eagerly, unlike
        -- for p2p nodes for which we start all mini-protocols on demand.
        -- Using 'miniProtocolStatusVar' is ok for unidirectional connection,
        -- as we never restart the protocols for them.  They transition to
        -- 'RemoteWarm' as soon the connection is accepted.  This is because
        -- for eagerly started mini-protocols mux puts them in 'StatusRunning'
        -- as soon as mini-protocols are set in place by 'runMiniProtocol'.
        RemoteState m
RemoteCold ->
          ((MiniProtocolNum, MiniProtocolDir)
 -> STM m MiniProtocolStatus
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
            (MiniProtocolNum, MiniProtocolDir)
-> STM m MiniProtocolStatus
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
fn
            (Mux muxMode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
Mux.miniProtocolStateMap Mux muxMode m
csMux)

        -- We skip it here; this case is done in 'firstPeerDemotedToCold'.
        RemoteIdle {} ->
          ((MiniProtocolNum, MiniProtocolDir)
 -> STM m MiniProtocolStatus
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
            (MiniProtocolNum, MiniProtocolDir)
-> STM m MiniProtocolStatus
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
fn
            (Mux muxMode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
Mux.miniProtocolStateMap Mux muxMode m
csMux)
  where
    fn :: (MiniProtocolNum, MiniProtocolDir)
       -> STM m MiniProtocolStatus
       -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
    fn :: (MiniProtocolNum, MiniProtocolDir)
-> STM m MiniProtocolStatus
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
fn = \(MiniProtocolNum
_miniProtocolNum, MiniProtocolDir
miniProtocolDir) STM m MiniProtocolStatus
miniProtocolStatus ->
      case MiniProtocolDir
miniProtocolDir of
        MiniProtocolDir
InitiatorDir -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty

        MiniProtocolDir
ResponderDir ->
          STM m (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m (Event muxMode peerAddr m a b)
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> STM m (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$
            STM m MiniProtocolStatus
miniProtocolStatus STM m MiniProtocolStatus
-> (MiniProtocolStatus -> STM m (Event muxMode peerAddr m a b))
-> STM m (Event muxMode peerAddr m a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              MiniProtocolStatus
StatusIdle          -> STM m (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
              MiniProtocolStatus
StatusStartOnDemand -> STM m (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
              MiniProtocolStatus
StatusRunning       -> Event muxMode peerAddr m a b
-> STM m (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event muxMode peerAddr m a b
 -> STM m (Event muxMode peerAddr m a b))
-> Event muxMode peerAddr m a b
-> STM m (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
AwakeRemote ConnectionId peerAddr
connId


-- | Detect when a first warm peer is promoted to hot (all hot mini-protocols
-- run running).
--
firstPeerPromotedToHot :: forall muxMode peerAddr m a b.
                          MonadSTM m
                       => EventSignal muxMode peerAddr m a b
firstPeerPromotedToHot :: EventSignal muxMode peerAddr m a b
firstPeerPromotedToHot
   ConnectionId peerAddr
connId connState :: ConnectionState muxMode peerAddr m a b
connState@ConnectionState { RemoteState m
csRemoteState :: RemoteState m
csRemoteState :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> RemoteState m
csRemoteState }
   = case RemoteState m
csRemoteState of
       RemoteState m
RemoteHot     -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty
       RemoteState m
RemoteWarm    ->
           LastToFinishM (STM m) (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. LastToFinishM m a -> FirstToFinish m a
lastToFirstM
         (LastToFinishM (STM m) (Event muxMode peerAddr m a b)
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> (LastToFinishM (STM m) ()
    -> LastToFinishM (STM m) (Event muxMode peerAddr m a b))
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Event muxMode peerAddr m a b)
-> LastToFinishM (STM m) ()
-> LastToFinishM (STM m) (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event muxMode peerAddr m a b -> () -> Event muxMode peerAddr m a b
forall a b. a -> b -> a
const (Event muxMode peerAddr m a b
 -> () -> Event muxMode peerAddr m a b)
-> Event muxMode peerAddr m a b
-> ()
-> Event muxMode peerAddr m a b
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
RemotePromotedToHot ConnectionId peerAddr
connId)
         (LastToFinishM (STM m) ()
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$ (STM m MiniProtocolStatus -> LastToFinishM (STM m) ())
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> LastToFinishM (STM m) ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap STM m MiniProtocolStatus -> LastToFinishM (STM m) ()
fn
             (ConnectionState muxMode peerAddr m a b
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
hotMiniProtocolStateMap ConnectionState muxMode peerAddr m a b
connState)
       RemoteState m
RemoteCold    ->
           LastToFinishM (STM m) (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. LastToFinishM m a -> FirstToFinish m a
lastToFirstM
         (LastToFinishM (STM m) (Event muxMode peerAddr m a b)
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> (LastToFinishM (STM m) ()
    -> LastToFinishM (STM m) (Event muxMode peerAddr m a b))
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Event muxMode peerAddr m a b)
-> LastToFinishM (STM m) ()
-> LastToFinishM (STM m) (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event muxMode peerAddr m a b -> () -> Event muxMode peerAddr m a b
forall a b. a -> b -> a
const (Event muxMode peerAddr m a b
 -> () -> Event muxMode peerAddr m a b)
-> Event muxMode peerAddr m a b
-> ()
-> Event muxMode peerAddr m a b
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
RemotePromotedToHot ConnectionId peerAddr
connId)
         (LastToFinishM (STM m) ()
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$ (STM m MiniProtocolStatus -> LastToFinishM (STM m) ())
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> LastToFinishM (STM m) ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap STM m MiniProtocolStatus -> LastToFinishM (STM m) ()
fn
             (ConnectionState muxMode peerAddr m a b
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
hotMiniProtocolStateMap ConnectionState muxMode peerAddr m a b
connState)
       RemoteIdle {} -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty
  where
    -- only hot mini-protocols;
    hotMiniProtocolStateMap :: ConnectionState muxMode peerAddr m a b
                            -> Map (MiniProtocolNum, MiniProtocolDir)
                                   (STM m MiniProtocolStatus)
    hotMiniProtocolStateMap :: ConnectionState muxMode peerAddr m a b
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
hotMiniProtocolStateMap ConnectionState { Mux muxMode m
csMux :: Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux, Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap } =
       Mux muxMode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
Mux.miniProtocolStateMap Mux muxMode m
csMux
       Map (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> Set (MiniProtocolNum, MiniProtocolDir)
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys`
       ( (MiniProtocolNum -> (MiniProtocolNum, MiniProtocolDir))
-> Set MiniProtocolNum -> Set (MiniProtocolNum, MiniProtocolDir)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (,MiniProtocolDir
ResponderDir)
       (Set MiniProtocolNum -> Set (MiniProtocolNum, MiniProtocolDir))
-> (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
    -> Set MiniProtocolNum)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set (MiniProtocolNum, MiniProtocolDir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set MiniProtocolNum
forall k a. Map k a -> Set k
Map.keysSet
       (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
 -> Set MiniProtocolNum)
-> (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
    -> Map MiniProtocolNum (MiniProtocolData muxMode m a b))
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set MiniProtocolNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiniProtocolData muxMode m a b -> Bool)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter
           (\MiniProtocolData { ProtocolTemperature
mpdMiniProtocolTemp :: forall (muxMode :: MuxMode) (m :: * -> *) a b.
MiniProtocolData muxMode m a b -> ProtocolTemperature
mpdMiniProtocolTemp :: ProtocolTemperature
mpdMiniProtocolTemp } ->
              case ProtocolTemperature
mpdMiniProtocolTemp of
                ProtocolTemperature
Hot -> Bool
True
                ProtocolTemperature
_   -> Bool
False
           )
       (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
 -> Set (MiniProtocolNum, MiniProtocolDir))
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set (MiniProtocolNum, MiniProtocolDir)
forall a b. (a -> b) -> a -> b
$ Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap
       )

    fn :: STM m MiniProtocolStatus
       -> LastToFinishM (STM m) ()
    fn :: STM m MiniProtocolStatus -> LastToFinishM (STM m) ()
fn STM m MiniProtocolStatus
miniProtocolStatus =
      STM m () -> LastToFinishM (STM m) ()
forall (m :: * -> *) a. m a -> LastToFinishM m a
LastToFinishM (STM m () -> LastToFinishM (STM m) ())
-> STM m () -> LastToFinishM (STM m) ()
forall a b. (a -> b) -> a -> b
$
        STM m MiniProtocolStatus
miniProtocolStatus STM m MiniProtocolStatus
-> (MiniProtocolStatus -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          MiniProtocolStatus
StatusIdle          -> STM m ()
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          MiniProtocolStatus
StatusStartOnDemand -> STM m ()
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          MiniProtocolStatus
StatusRunning       -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Detect when a first hot mini-protocols terminates, which triggers the
-- `RemoteHot → RemoteWarm` transition.
--
firstPeerDemotedToWarm :: forall muxMode peerAddr m a b.
                          MonadSTM m
                       => EventSignal muxMode peerAddr m a b
firstPeerDemotedToWarm :: EventSignal muxMode peerAddr m a b
firstPeerDemotedToWarm
    ConnectionId peerAddr
connId connState :: ConnectionState muxMode peerAddr m a b
connState@ConnectionState { RemoteState m
csRemoteState :: RemoteState m
csRemoteState :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> RemoteState m
csRemoteState }
    = case RemoteState m
csRemoteState of
        RemoteState m
RemoteHot ->
              Event muxMode peerAddr m a b -> () -> Event muxMode peerAddr m a b
forall a b. a -> b -> a
const (ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
RemoteDemotedToWarm ConnectionId peerAddr
connId)
          (() -> Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (STM m MiniProtocolStatus -> FirstToFinish (STM m) ())
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> FirstToFinish (STM m) ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap STM m MiniProtocolStatus -> FirstToFinish (STM m) ()
fn (ConnectionState muxMode peerAddr m a b
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
hotMiniProtocolStateMap ConnectionState muxMode peerAddr m a b
connState)

        RemoteState m
_  -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty
  where
    -- only hot mini-protocols;
    hotMiniProtocolStateMap :: ConnectionState muxMode peerAddr m a b
                            -> Map (MiniProtocolNum, MiniProtocolDir)
                                   (STM m MiniProtocolStatus)
    hotMiniProtocolStateMap :: ConnectionState muxMode peerAddr m a b
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
hotMiniProtocolStateMap ConnectionState { Mux muxMode m
csMux :: Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux, Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap } =
       Mux muxMode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
Mux.miniProtocolStateMap Mux muxMode m
csMux
       Map (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> Set (MiniProtocolNum, MiniProtocolDir)
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys`
       ( (MiniProtocolNum -> (MiniProtocolNum, MiniProtocolDir))
-> Set MiniProtocolNum -> Set (MiniProtocolNum, MiniProtocolDir)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (,MiniProtocolDir
ResponderDir)
       (Set MiniProtocolNum -> Set (MiniProtocolNum, MiniProtocolDir))
-> (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
    -> Set MiniProtocolNum)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set (MiniProtocolNum, MiniProtocolDir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set MiniProtocolNum
forall k a. Map k a -> Set k
Map.keysSet
       (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
 -> Set MiniProtocolNum)
-> (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
    -> Map MiniProtocolNum (MiniProtocolData muxMode m a b))
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set MiniProtocolNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiniProtocolData muxMode m a b -> Bool)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter
           (\MiniProtocolData { ProtocolTemperature
mpdMiniProtocolTemp :: ProtocolTemperature
mpdMiniProtocolTemp :: forall (muxMode :: MuxMode) (m :: * -> *) a b.
MiniProtocolData muxMode m a b -> ProtocolTemperature
mpdMiniProtocolTemp } ->
                case ProtocolTemperature
mpdMiniProtocolTemp of
                  ProtocolTemperature
Hot -> Bool
True
                  ProtocolTemperature
_   -> Bool
False
           )
       (Map MiniProtocolNum (MiniProtocolData muxMode m a b)
 -> Set (MiniProtocolNum, MiniProtocolDir))
-> Map MiniProtocolNum (MiniProtocolData muxMode m a b)
-> Set (MiniProtocolNum, MiniProtocolDir)
forall a b. (a -> b) -> a -> b
$ Map MiniProtocolNum (MiniProtocolData muxMode m a b)
csMiniProtocolMap
       )

    fn :: STM m MiniProtocolStatus
       -> FirstToFinish (STM m) ()
    fn :: STM m MiniProtocolStatus -> FirstToFinish (STM m) ()
fn STM m MiniProtocolStatus
miniProtocolStatus =
      STM m () -> FirstToFinish (STM m) ()
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m () -> FirstToFinish (STM m) ())
-> STM m () -> FirstToFinish (STM m) ()
forall a b. (a -> b) -> a -> b
$
        STM m MiniProtocolStatus
miniProtocolStatus STM m MiniProtocolStatus
-> (MiniProtocolStatus -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          MiniProtocolStatus
StatusIdle          -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          MiniProtocolStatus
StatusStartOnDemand -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          MiniProtocolStatus
StatusRunning       -> STM m ()
forall (m :: * -> *) a. MonadSTM m => STM m a
retry


-- | Await for first peer demoted to cold, i.e. detect the
-- @DemotedToCold^{Duplex}_{Remote}@.
--
-- /triggers:/ 'DemotedToColdRemote'
--
firstPeerDemotedToCold :: MonadSTM m
                       => EventSignal muxMode peerAddr m a b
firstPeerDemotedToCold :: EventSignal muxMode peerAddr m a b
firstPeerDemotedToCold
    ConnectionId peerAddr
connId
    ConnectionState {
      Mux muxMode m
csMux :: Mux muxMode m
csMux :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> Mux muxMode m
csMux,
      RemoteState m
csRemoteState :: RemoteState m
csRemoteState :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> RemoteState m
csRemoteState
    }
    = case RemoteState m
csRemoteState of
        -- the connection is already in 'RemoteCold' state
        RemoteState m
RemoteCold -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty

        -- Responders are started using 'StartOnDemand' strategy. We detect
        -- when all of the responders are in 'StatusIdle' or
        -- 'StatusStartOnDemand' and subsequently put the connection in
        -- 'RemoteIdle' state.
        --
        -- In compat mode, when established mini-protocols terminate they will
        -- not be restarted.
        RemoteState m
RemoteEstablished ->
              (() -> Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event muxMode peerAddr m a b -> () -> Event muxMode peerAddr m a b
forall a b. a -> b -> a
const (Event muxMode peerAddr m a b
 -> () -> Event muxMode peerAddr m a b)
-> Event muxMode peerAddr m a b
-> ()
-> Event muxMode peerAddr m a b
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
WaitIdleRemote ConnectionId peerAddr
connId)
            (FirstToFinish (STM m) ()
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> (LastToFinishM (STM m) () -> FirstToFinish (STM m) ())
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LastToFinishM (STM m) () -> FirstToFinish (STM m) ()
forall (m :: * -> *) a. LastToFinishM m a -> FirstToFinish m a
lastToFirstM
            (LastToFinishM (STM m) ()
 -> FirstToFinish (STM m) (Event muxMode peerAddr m a b))
-> LastToFinishM (STM m) ()
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a b. (a -> b) -> a -> b
$ (((MiniProtocolNum, MiniProtocolDir)
 -> STM m MiniProtocolStatus -> LastToFinishM (STM m) ())
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
-> LastToFinishM (STM m) ()
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
                (\(MiniProtocolNum
_, MiniProtocolDir
miniProtocolDir) STM m MiniProtocolStatus
miniProtocolStatus ->
                  case MiniProtocolDir
miniProtocolDir of
                    MiniProtocolDir
InitiatorDir -> LastToFinishM (STM m) ()
forall a. Monoid a => a
mempty

                    MiniProtocolDir
ResponderDir ->
                      STM m () -> LastToFinishM (STM m) ()
forall (m :: * -> *) a. m a -> LastToFinishM m a
LastToFinishM (STM m () -> LastToFinishM (STM m) ())
-> STM m () -> LastToFinishM (STM m) ()
forall a b. (a -> b) -> a -> b
$ do
                        STM m MiniProtocolStatus
miniProtocolStatus STM m MiniProtocolStatus
-> (MiniProtocolStatus -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          MiniProtocolStatus
StatusIdle          -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          MiniProtocolStatus
StatusStartOnDemand -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          MiniProtocolStatus
StatusRunning       -> STM m ()
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                )
                (Mux muxMode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m
-> Map
     (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus)
Mux.miniProtocolStateMap Mux muxMode m
csMux)
              )

        RemoteIdle {} -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty


-- | First peer for which the 'RemoteIdle' timeout expires.
--
firstPeerCommitRemote :: MonadSTM m
                      => EventSignal muxMode peerAddr m a b
firstPeerCommitRemote :: EventSignal muxMode peerAddr m a b
firstPeerCommitRemote
    ConnectionId peerAddr
connId ConnectionState { RemoteState m
csRemoteState :: RemoteState m
csRemoteState :: forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionState muxMode peerAddr m a b -> RemoteState m
csRemoteState }
    = case RemoteState m
csRemoteState of
        -- the connection is already in 'RemoteCold' state
        RemoteState m
RemoteCold            -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty
        RemoteState m
RemoteEstablished     -> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall a. Monoid a => a
mempty
        RemoteIdle STM m ()
timeoutSTM -> STM m (Event muxMode peerAddr m a b)
-> FirstToFinish (STM m) (Event muxMode peerAddr m a b)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m ()
timeoutSTM STM m ()
-> Event muxMode peerAddr m a b
-> STM m (Event muxMode peerAddr m a b)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ConnectionId peerAddr -> Event muxMode peerAddr m a b
forall (muxMode :: MuxMode) peerAddr (m :: * -> *) a b.
ConnectionId peerAddr -> Event muxMode peerAddr m a b
CommitRemote ConnectionId peerAddr
connId)