{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Ouroboros.Network.InboundGovernor.State
( PublicState (..)
, mkPublicState
, State (..)
, ConnectionState (..)
, Counters (..)
, counters
, unregisterConnection
, updateMiniProtocol
, RemoteState (.., RemoteEstablished)
, RemoteSt (..)
, mkRemoteSt
, updateRemoteState
, mapRemoteState
, MiniProtocolData (..)
) where
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (assert)
import Control.Monad.Class.MonadThrow hiding (handle)
import Control.Monad.Class.MonadTime.SI
import Data.ByteString.Lazy (ByteString)
import Data.Cache (Cache)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.OrdPSQ as OrdPSQ
import Network.Mux qualified as Mux
import Ouroboros.Network.Context
import Ouroboros.Network.Mux
data PublicState peerAddr versionData = PublicState {
forall peerAddr versionData.
PublicState peerAddr versionData -> Map peerAddr versionData
inboundDuplexPeers :: !(Map peerAddr versionData),
forall peerAddr versionData.
PublicState peerAddr versionData
-> Map (ConnectionId peerAddr) RemoteSt
remoteStateMap :: Map (ConnectionId peerAddr) RemoteSt
}
mkPublicState
:: forall muxMode initatorCtx versionData peerAddr m a b.
State muxMode initatorCtx peerAddr versionData m a b
-> PublicState peerAddr versionData
mkPublicState :: forall (muxMode :: Mode) initatorCtx versionData peerAddr
(m :: * -> *) a b.
State muxMode initatorCtx peerAddr versionData m a b
-> PublicState peerAddr versionData
mkPublicState
State { Map
(ConnectionId peerAddr)
(ConnectionState muxMode initatorCtx peerAddr versionData m a b)
connections :: Map
(ConnectionId peerAddr)
(ConnectionState muxMode initatorCtx peerAddr versionData m a b)
connections :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections, Map peerAddr versionData
matureDuplexPeers :: Map peerAddr versionData
matureDuplexPeers :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Map peerAddr versionData
matureDuplexPeers }
=
PublicState {
inboundDuplexPeers :: Map peerAddr versionData
inboundDuplexPeers = Map peerAddr versionData
matureDuplexPeers,
remoteStateMap :: Map (ConnectionId peerAddr) RemoteSt
remoteStateMap = (ConnectionState muxMode initatorCtx peerAddr versionData m a b
-> RemoteSt)
-> Map
(ConnectionId peerAddr)
(ConnectionState muxMode initatorCtx peerAddr versionData m a b)
-> Map (ConnectionId peerAddr) RemoteSt
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (RemoteState m -> RemoteSt
forall (m :: * -> *). RemoteState m -> RemoteSt
mkRemoteSt (RemoteState m -> RemoteSt)
-> (ConnectionState muxMode initatorCtx peerAddr versionData m a b
-> RemoteState m)
-> ConnectionState muxMode initatorCtx peerAddr versionData m a b
-> RemoteSt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState muxMode initatorCtx peerAddr versionData m a b
-> RemoteState m
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> RemoteState m
csRemoteState) Map
(ConnectionId peerAddr)
(ConnectionState muxMode initatorCtx peerAddr versionData m a b)
connections
}
data State muxMode initiatorCtx peerAddr versionData m a b =
State {
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections :: !(Map (ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Map peerAddr versionData
matureDuplexPeers :: !(Map peerAddr versionData),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> OrdPSQ peerAddr Time versionData
freshDuplexPeers :: !(OrdPSQ peerAddr Time versionData),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Cache Counters
countersCache :: !(Cache Counters)
}
data Counters = Counters {
Counters -> Int
coldPeersRemote :: !Int,
Counters -> Int
idlePeersRemote :: !Int,
Counters -> Int
warmPeersRemote :: !Int,
Counters -> Int
hotPeersRemote :: !Int
}
deriving (Counters -> Counters -> Bool
(Counters -> Counters -> Bool)
-> (Counters -> Counters -> Bool) -> Eq Counters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Counters -> Counters -> Bool
== :: Counters -> Counters -> Bool
$c/= :: Counters -> Counters -> Bool
/= :: Counters -> Counters -> Bool
Eq, Eq Counters
Eq Counters =>
(Counters -> Counters -> Ordering)
-> (Counters -> Counters -> Bool)
-> (Counters -> Counters -> Bool)
-> (Counters -> Counters -> Bool)
-> (Counters -> Counters -> Bool)
-> (Counters -> Counters -> Counters)
-> (Counters -> Counters -> Counters)
-> Ord Counters
Counters -> Counters -> Bool
Counters -> Counters -> Ordering
Counters -> Counters -> Counters
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Counters -> Counters -> Ordering
compare :: Counters -> Counters -> Ordering
$c< :: Counters -> Counters -> Bool
< :: Counters -> Counters -> Bool
$c<= :: Counters -> Counters -> Bool
<= :: Counters -> Counters -> Bool
$c> :: Counters -> Counters -> Bool
> :: Counters -> Counters -> Bool
$c>= :: Counters -> Counters -> Bool
>= :: Counters -> Counters -> Bool
$cmax :: Counters -> Counters -> Counters
max :: Counters -> Counters -> Counters
$cmin :: Counters -> Counters -> Counters
min :: Counters -> Counters -> Counters
Ord, Int -> Counters -> ShowS
[Counters] -> ShowS
Counters -> String
(Int -> Counters -> ShowS)
-> (Counters -> String) -> ([Counters] -> ShowS) -> Show Counters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Counters -> ShowS
showsPrec :: Int -> Counters -> ShowS
$cshow :: Counters -> String
show :: Counters -> String
$cshowList :: [Counters] -> ShowS
showList :: [Counters] -> ShowS
Show)
instance Semigroup Counters where
Counters Int
c Int
i Int
w Int
h <> :: Counters -> Counters -> Counters
<> Counters Int
c' Int
i' Int
w' Int
h' =
Int -> Int -> Int -> Int -> Counters
Counters (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c') (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i') (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w') (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h')
instance Monoid Counters where
mempty :: Counters
mempty = Int -> Int -> Int -> Int -> Counters
Counters Int
0 Int
0 Int
0 Int
0
counters :: State muxMode initiatorCtx peerAddr versionData m a b
-> Counters
counters :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b -> Counters
counters State { Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
State muxMode initiatorCtx peerAddr versionData m a b
-> Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections :: Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections } =
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> Counters)
-> Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
-> Counters
forall m a.
Monoid m =>
(a -> m) -> Map (ConnectionId peerAddr) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\ConnectionState { RemoteState m
csRemoteState :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> RemoteState m
csRemoteState :: RemoteState m
csRemoteState } ->
case RemoteState m
csRemoteState of
RemoteState m
RemoteCold -> Int -> Int -> Int -> Int -> Counters
Counters Int
1 Int
0 Int
0 Int
0
RemoteIdle {} -> Int -> Int -> Int -> Int -> Counters
Counters Int
0 Int
1 Int
0 Int
0
RemoteState m
RemoteWarm -> Int -> Int -> Int -> Int -> Counters
Counters Int
0 Int
0 Int
1 Int
0
RemoteState m
RemoteHot -> Int -> Int -> Int -> Int -> Counters
Counters Int
0 Int
0 Int
0 Int
1
)
Map
(ConnectionId peerAddr)
(ConnectionState muxMode initiatorCtx peerAddr versionData m a b)
connections
data MiniProtocolData muxMode initiatorCtx peerAddr m a b = MiniProtocolData {
forall (muxMode :: Mode) initiatorCtx peerAddr (m :: * -> *) a b.
MiniProtocolData muxMode initiatorCtx peerAddr m a b
-> MiniProtocol
muxMode initiatorCtx (ResponderContext peerAddr) ByteString m a b
mpdMiniProtocol :: !(MiniProtocol muxMode initiatorCtx (ResponderContext peerAddr) ByteString m a b),
forall (muxMode :: Mode) initiatorCtx peerAddr (m :: * -> *) a b.
MiniProtocolData muxMode initiatorCtx peerAddr m a b
-> ResponderContext peerAddr
mpdResponderContext :: !(ResponderContext peerAddr),
forall (muxMode :: Mode) initiatorCtx peerAddr (m :: * -> *) a b.
MiniProtocolData muxMode initiatorCtx peerAddr m a b
-> ProtocolTemperature
mpdMiniProtocolTemp :: !ProtocolTemperature
}
data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = ConnectionState {
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> Mux muxMode m
csMux :: !(Mux.Mux muxMode m),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> versionData
csVersionData :: !versionData,
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> Map
MiniProtocolNum
(MiniProtocolData muxMode initiatorCtx peerAddr m a b)
csMiniProtocolMap :: !(Map MiniProtocolNum
(MiniProtocolData muxMode initiatorCtx peerAddr m a b)),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap :: !(Map MiniProtocolNum
(STM m (Either SomeException b))),
forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> RemoteState m
csRemoteState :: !(RemoteState m)
}
unregisterConnection :: Ord peerAddr
=> ConnectionId peerAddr
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
unregisterConnection :: forall peerAddr (muxMode :: Mode) initiatorCtx versionData
(m :: * -> *) a b.
Ord peerAddr =>
ConnectionId peerAddr
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
unregisterConnection ConnectionId peerAddr
connId State muxMode initiatorCtx peerAddr versionData m a b
state =
State muxMode initiatorCtx peerAddr versionData m a b
state { connections =
assert (connId `Map.member` connections state) $
Map.delete connId (connections state),
matureDuplexPeers =
Map.delete (remoteAddress connId) (matureDuplexPeers state),
freshDuplexPeers =
OrdPSQ.delete (remoteAddress connId) (freshDuplexPeers state)
}
updateMiniProtocol :: Ord peerAddr
=> ConnectionId peerAddr
-> MiniProtocolNum
-> STM m (Either SomeException b)
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
updateMiniProtocol :: forall peerAddr (m :: * -> *) b (muxMode :: Mode) initiatorCtx
versionData a.
Ord peerAddr =>
ConnectionId peerAddr
-> MiniProtocolNum
-> STM m (Either SomeException b)
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
updateMiniProtocol ConnectionId peerAddr
connId MiniProtocolNum
miniProtocolNum STM m (Either SomeException b)
completionAction State muxMode initiatorCtx peerAddr versionData m a b
state =
State muxMode initiatorCtx peerAddr versionData m a b
state { connections =
Map.adjust (\connState :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState@ConnectionState { Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap :: Map MiniProtocolNum (STM m (Either SomeException b))
csCompletionMap } ->
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState {
csCompletionMap =
assert (miniProtocolNum `Map.member` csCompletionMap) $
Map.insert miniProtocolNum
completionAction
csCompletionMap
}
)
connId
(connections state)
}
data RemoteState m
= RemoteWarm
| RemoteHot
| RemoteIdle !(STM m ())
| RemoteCold
remoteEstablished :: RemoteState m -> Maybe (RemoteState m)
remoteEstablished :: forall (m :: * -> *). RemoteState m -> Maybe (RemoteState m)
remoteEstablished a :: RemoteState m
a@RemoteState m
RemoteWarm = RemoteState m -> Maybe (RemoteState m)
forall a. a -> Maybe a
Just RemoteState m
a
remoteEstablished a :: RemoteState m
a@RemoteState m
RemoteHot = RemoteState m -> Maybe (RemoteState m)
forall a. a -> Maybe a
Just RemoteState m
a
remoteEstablished RemoteState m
_ = Maybe (RemoteState m)
forall a. Maybe a
Nothing
pattern RemoteEstablished :: RemoteState m
pattern $mRemoteEstablished :: forall {r} {m :: * -> *}.
RemoteState m -> ((# #) -> r) -> ((# #) -> r) -> r
RemoteEstablished <- (remoteEstablished -> Just _)
{-# COMPLETE RemoteEstablished, RemoteIdle, RemoteCold #-}
updateRemoteState :: Ord peerAddr
=> ConnectionId peerAddr
-> RemoteState m
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
updateRemoteState :: forall peerAddr (m :: * -> *) (muxMode :: Mode) initiatorCtx
versionData a b.
Ord peerAddr =>
ConnectionId peerAddr
-> RemoteState m
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
updateRemoteState ConnectionId peerAddr
connId RemoteState m
csRemoteState State muxMode initiatorCtx peerAddr versionData m a b
state =
State muxMode initiatorCtx peerAddr versionData m a b
state {
connections =
Map.adjust
(\ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState { csRemoteState })
connId
(connections state)
}
mapRemoteState :: Ord peerAddr
=> ConnectionId peerAddr
-> (RemoteState m -> RemoteState m)
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
mapRemoteState :: forall peerAddr (m :: * -> *) (muxMode :: Mode) initiatorCtx
versionData a b.
Ord peerAddr =>
ConnectionId peerAddr
-> (RemoteState m -> RemoteState m)
-> State muxMode initiatorCtx peerAddr versionData m a b
-> State muxMode initiatorCtx peerAddr versionData m a b
mapRemoteState ConnectionId peerAddr
connId RemoteState m -> RemoteState m
fn State muxMode initiatorCtx peerAddr versionData m a b
state =
State muxMode initiatorCtx peerAddr versionData m a b
state {
connections =
Map.adjust
(\connState :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState@ConnectionState { RemoteState m
csRemoteState :: forall (muxMode :: Mode) initiatorCtx peerAddr versionData
(m :: * -> *) a b.
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
-> RemoteState m
csRemoteState :: RemoteState m
csRemoteState } ->
ConnectionState muxMode initiatorCtx peerAddr versionData m a b
connState { csRemoteState = fn csRemoteState })
connId
(connections state)
}
data RemoteSt = RemoteWarmSt
| RemoteHotSt
| RemoteIdleSt
| RemoteColdSt
deriving (RemoteSt -> RemoteSt -> Bool
(RemoteSt -> RemoteSt -> Bool)
-> (RemoteSt -> RemoteSt -> Bool) -> Eq RemoteSt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RemoteSt -> RemoteSt -> Bool
== :: RemoteSt -> RemoteSt -> Bool
$c/= :: RemoteSt -> RemoteSt -> Bool
/= :: RemoteSt -> RemoteSt -> Bool
Eq, Int -> RemoteSt -> ShowS
[RemoteSt] -> ShowS
RemoteSt -> String
(Int -> RemoteSt -> ShowS)
-> (RemoteSt -> String) -> ([RemoteSt] -> ShowS) -> Show RemoteSt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RemoteSt -> ShowS
showsPrec :: Int -> RemoteSt -> ShowS
$cshow :: RemoteSt -> String
show :: RemoteSt -> String
$cshowList :: [RemoteSt] -> ShowS
showList :: [RemoteSt] -> ShowS
Show)
mkRemoteSt :: RemoteState m -> RemoteSt
mkRemoteSt :: forall (m :: * -> *). RemoteState m -> RemoteSt
mkRemoteSt RemoteState m
RemoteWarm = RemoteSt
RemoteWarmSt
mkRemoteSt RemoteState m
RemoteHot = RemoteSt
RemoteHotSt
mkRemoteSt (RemoteIdle STM m ()
_) = RemoteSt
RemoteIdleSt
mkRemoteSt RemoteState m
RemoteCold = RemoteSt
RemoteColdSt