{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Metro.Server
  ( startServer
  , startServer_
  , ServerEnv
  , ServerT
  , Servable (..)
  , getNodeEnvList
  , getServ
  , serverEnv
  , initServerEnv

  -- server env action
  , setServerName
  , setNodeMode
  , setSessionMode
  , setDefaultSessionTimeout
  , setKeepalive

  , setOnNodeLeave

  , runServerT
  , stopServerT
  , handleConn
  ) where

import           Control.Monad              (forM_, forever, unless, void, when)
import           Control.Monad.Cont         (callCC, runContT)
import           Control.Monad.Reader.Class (MonadReader (ask), asks)
import           Control.Monad.Trans.Class  (MonadTrans, lift)
import           Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
import           Data.Either                (isLeft)
import           Data.Hashable
import           Data.IOHashMap             (IOHashMap)
import qualified Data.IOHashMap             as HM (delete, elems, empty)
import qualified Data.IOHashMap.STM         as HMS (insert, lookup)
import           Data.Int                   (Int64)
import           Metro.Class                (GetPacketId, RecvPacket,
                                             Servable (..), Transport,
                                             TransportConfig)
import           Metro.Conn                 hiding (close)
import           Metro.Node                 (NodeEnv1, NodeMode (..),
                                             SessionMode (..), getNodeId,
                                             getTimer, initEnv1, runNodeT1,
                                             startNodeT_, stopNodeT)
import qualified Metro.Node                 as Node
import           Metro.Session              (SessionT)
import           Metro.Utils                (getEpochTime)
import           System.Log.Logger          (errorM, infoM)
import           UnliftIO
import           UnliftIO.Concurrent        (threadDelay)

data ServerEnv serv u nid k rpkt tp = ServerEnv
    { ServerEnv serv u nid k rpkt tp -> serv
serveServ    :: serv
    , ServerEnv serv u nid k rpkt tp -> TVar Bool
serveState   :: TVar Bool
    , ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList  :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
    , ServerEnv serv u nid k rpkt tp
-> SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
prepare      :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
    , ServerEnv serv u nid k rpkt tp -> IO k
gen          :: IO k
    , ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive    :: TVar Int64 -- client keepalive seconds
    , ServerEnv serv u nid k rpkt tp -> TVar Int64
defSessTout  :: TVar Int64 -- session timeout seconds
    , ServerEnv serv u nid k rpkt tp -> NodeMode
nodeMode     :: NodeMode
    , ServerEnv serv u nid k rpkt tp -> SessionMode
sessionMode  :: SessionMode
    , ServerEnv serv u nid k rpkt tp -> String
serveName    :: String
    , ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
onNodeLeave  :: TVar (Maybe (nid -> u -> IO ()))
    , ServerEnv serv u nid k rpkt tp
-> TransportConfig (STP serv) -> TransportConfig tp
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
    }


newtype ServerT serv u nid k rpkt tp m a = ServerT {ServerT serv u nid k rpkt tp m a
-> ReaderT (ServerEnv serv u nid k rpkt tp) m a
unServerT :: ReaderT (ServerEnv serv u nid k rpkt tp) m a}
  deriving
    ( a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
(a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
(forall a b.
 (a -> b)
 -> ServerT serv u nid k rpkt tp m a
 -> ServerT serv u nid k rpkt tp m b)
-> (forall a b.
    a
    -> ServerT serv u nid k rpkt tp m b
    -> ServerT serv u nid k rpkt tp m a)
-> Functor (ServerT serv u nid k rpkt tp m)
forall a b.
a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
forall a b.
(a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *) a b.
Functor m =>
a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *) a b.
Functor m =>
(a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
$c<$ :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Functor m =>
a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
fmap :: (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
$cfmap :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Functor m =>
(a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
Functor
    , Functor (ServerT serv u nid k rpkt tp m)
a -> ServerT serv u nid k rpkt tp m a
Functor (ServerT serv u nid k rpkt tp m)
-> (forall a. a -> ServerT serv u nid k rpkt tp m a)
-> (forall a b.
    ServerT serv u nid k rpkt tp m (a -> b)
    -> ServerT serv u nid k rpkt tp m a
    -> ServerT serv u nid k rpkt tp m b)
-> (forall a b c.
    (a -> b -> c)
    -> ServerT serv u nid k rpkt tp m a
    -> ServerT serv u nid k rpkt tp m b
    -> ServerT serv u nid k rpkt tp m c)
-> (forall a b.
    ServerT serv u nid k rpkt tp m a
    -> ServerT serv u nid k rpkt tp m b
    -> ServerT serv u nid k rpkt tp m b)
-> (forall a b.
    ServerT serv u nid k rpkt tp m a
    -> ServerT serv u nid k rpkt tp m b
    -> ServerT serv u nid k rpkt tp m a)
-> Applicative (ServerT serv u nid k rpkt tp m)
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
ServerT serv u nid k rpkt tp m (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
(a -> b -> c)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m c
forall a. a -> ServerT serv u nid k rpkt tp m a
forall a b.
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
forall a b.
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
forall a b.
ServerT serv u nid k rpkt tp m (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
forall a b c.
(a -> b -> c)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m c
forall serv u nid k rpkt tp (m :: * -> *).
Applicative m =>
Functor (ServerT serv u nid k rpkt tp m)
forall serv u nid k rpkt tp (m :: * -> *) a.
Applicative m =>
a -> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
$c<* :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m a
*> :: ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
$c*> :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
liftA2 :: (a -> b -> c)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m c
$cliftA2 :: forall serv u nid k rpkt tp (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m c
<*> :: ServerT serv u nid k rpkt tp m (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
$c<*> :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Applicative m =>
ServerT serv u nid k rpkt tp m (a -> b)
-> ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
pure :: a -> ServerT serv u nid k rpkt tp m a
$cpure :: forall serv u nid k rpkt tp (m :: * -> *) a.
Applicative m =>
a -> ServerT serv u nid k rpkt tp m a
$cp1Applicative :: forall serv u nid k rpkt tp (m :: * -> *).
Applicative m =>
Functor (ServerT serv u nid k rpkt tp m)
Applicative
    , Applicative (ServerT serv u nid k rpkt tp m)
a -> ServerT serv u nid k rpkt tp m a
Applicative (ServerT serv u nid k rpkt tp m)
-> (forall a b.
    ServerT serv u nid k rpkt tp m a
    -> (a -> ServerT serv u nid k rpkt tp m b)
    -> ServerT serv u nid k rpkt tp m b)
-> (forall a b.
    ServerT serv u nid k rpkt tp m a
    -> ServerT serv u nid k rpkt tp m b
    -> ServerT serv u nid k rpkt tp m b)
-> (forall a. a -> ServerT serv u nid k rpkt tp m a)
-> Monad (ServerT serv u nid k rpkt tp m)
ServerT serv u nid k rpkt tp m a
-> (a -> ServerT serv u nid k rpkt tp m b)
-> ServerT serv u nid k rpkt tp m b
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
forall a. a -> ServerT serv u nid k rpkt tp m a
forall a b.
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
forall a b.
ServerT serv u nid k rpkt tp m a
-> (a -> ServerT serv u nid k rpkt tp m b)
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *).
Monad m =>
Applicative (ServerT serv u nid k rpkt tp m)
forall serv u nid k rpkt tp (m :: * -> *) a.
Monad m =>
a -> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *) a b.
Monad m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *) a b.
Monad m =>
ServerT serv u nid k rpkt tp m a
-> (a -> ServerT serv u nid k rpkt tp m b)
-> ServerT serv u nid k rpkt tp m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ServerT serv u nid k rpkt tp m a
$creturn :: forall serv u nid k rpkt tp (m :: * -> *) a.
Monad m =>
a -> ServerT serv u nid k rpkt tp m a
>> :: ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
$c>> :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Monad m =>
ServerT serv u nid k rpkt tp m a
-> ServerT serv u nid k rpkt tp m b
-> ServerT serv u nid k rpkt tp m b
>>= :: ServerT serv u nid k rpkt tp m a
-> (a -> ServerT serv u nid k rpkt tp m b)
-> ServerT serv u nid k rpkt tp m b
$c>>= :: forall serv u nid k rpkt tp (m :: * -> *) a b.
Monad m =>
ServerT serv u nid k rpkt tp m a
-> (a -> ServerT serv u nid k rpkt tp m b)
-> ServerT serv u nid k rpkt tp m b
$cp1Monad :: forall serv u nid k rpkt tp (m :: * -> *).
Monad m =>
Applicative (ServerT serv u nid k rpkt tp m)
Monad
    , Monad (ServerT serv u nid k rpkt tp m)
Monad (ServerT serv u nid k rpkt tp m)
-> (forall a. IO a -> ServerT serv u nid k rpkt tp m a)
-> MonadIO (ServerT serv u nid k rpkt tp m)
IO a -> ServerT serv u nid k rpkt tp m a
forall a. IO a -> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *).
MonadIO m =>
Monad (ServerT serv u nid k rpkt tp m)
forall serv u nid k rpkt tp (m :: * -> *) a.
MonadIO m =>
IO a -> ServerT serv u nid k rpkt tp m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ServerT serv u nid k rpkt tp m a
$cliftIO :: forall serv u nid k rpkt tp (m :: * -> *) a.
MonadIO m =>
IO a -> ServerT serv u nid k rpkt tp m a
$cp1MonadIO :: forall serv u nid k rpkt tp (m :: * -> *).
MonadIO m =>
Monad (ServerT serv u nid k rpkt tp m)
MonadIO
    , MonadReader (ServerEnv serv u nid k rpkt tp)
    )

instance MonadTrans (ServerT serv u nid k rpkt tp) where
  lift :: m a -> ServerT serv u nid k rpkt tp m a
lift = ReaderT (ServerEnv serv u nid k rpkt tp) m a
-> ServerT serv u nid k rpkt tp m a
forall serv u nid k rpkt tp (m :: * -> *) a.
ReaderT (ServerEnv serv u nid k rpkt tp) m a
-> ServerT serv u nid k rpkt tp m a
ServerT (ReaderT (ServerEnv serv u nid k rpkt tp) m a
 -> ServerT serv u nid k rpkt tp m a)
-> (m a -> ReaderT (ServerEnv serv u nid k rpkt tp) m a)
-> m a
-> ServerT serv u nid k rpkt tp m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (ServerEnv serv u nid k rpkt tp) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadUnliftIO m => MonadUnliftIO (ServerT serv u nid k rpkt tp m) where
  withRunInIO :: ((forall a. ServerT serv u nid k rpkt tp m a -> IO a) -> IO b)
-> ServerT serv u nid k rpkt tp m b
withRunInIO (forall a. ServerT serv u nid k rpkt tp m a -> IO a) -> IO b
inner = ReaderT (ServerEnv serv u nid k rpkt tp) m b
-> ServerT serv u nid k rpkt tp m b
forall serv u nid k rpkt tp (m :: * -> *) a.
ReaderT (ServerEnv serv u nid k rpkt tp) m a
-> ServerT serv u nid k rpkt tp m a
ServerT (ReaderT (ServerEnv serv u nid k rpkt tp) m b
 -> ServerT serv u nid k rpkt tp m b)
-> ReaderT (ServerEnv serv u nid k rpkt tp) m b
-> ServerT serv u nid k rpkt tp m b
forall a b. (a -> b) -> a -> b
$
    (ServerEnv serv u nid k rpkt tp -> m b)
-> ReaderT (ServerEnv serv u nid k rpkt tp) m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((ServerEnv serv u nid k rpkt tp -> m b)
 -> ReaderT (ServerEnv serv u nid k rpkt tp) m b)
-> (ServerEnv serv u nid k rpkt tp -> m b)
-> ReaderT (ServerEnv serv u nid k rpkt tp) m b
forall a b. (a -> b) -> a -> b
$ \ServerEnv serv u nid k rpkt tp
r ->
      ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
        (forall a. ServerT serv u nid k rpkt tp m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (ServerT serv u nid k rpkt tp m a -> m a)
-> ServerT serv u nid k rpkt tp m a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m a -> m a
forall serv u nid k rpkt tp (m :: * -> *) a.
ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m a -> m a
runServerT ServerEnv serv u nid k rpkt tp
r)

runServerT :: ServerEnv serv u nid k rpkt tp -> ServerT serv u nid k rpkt tp m a -> m a
runServerT :: ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m a -> m a
runServerT ServerEnv serv u nid k rpkt tp
sEnv = (ReaderT (ServerEnv serv u nid k rpkt tp) m a
 -> ServerEnv serv u nid k rpkt tp -> m a)
-> ServerEnv serv u nid k rpkt tp
-> ReaderT (ServerEnv serv u nid k rpkt tp) m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (ServerEnv serv u nid k rpkt tp) m a
-> ServerEnv serv u nid k rpkt tp -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ServerEnv serv u nid k rpkt tp
sEnv (ReaderT (ServerEnv serv u nid k rpkt tp) m a -> m a)
-> (ServerT serv u nid k rpkt tp m a
    -> ReaderT (ServerEnv serv u nid k rpkt tp) m a)
-> ServerT serv u nid k rpkt tp m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT serv u nid k rpkt tp m a
-> ReaderT (ServerEnv serv u nid k rpkt tp) m a
forall serv u nid k rpkt tp (m :: * -> *) a.
ServerT serv u nid k rpkt tp m a
-> ReaderT (ServerEnv serv u nid k rpkt tp) m a
unServerT

initServerEnv
  :: (MonadIO m, Servable serv)
  => ServerConfig serv -> IO k
  -> (TransportConfig (STP serv) -> TransportConfig tp)
  -> (SID serv -> ConnEnv tp -> IO (Maybe (nid, u)))
  -> m (ServerEnv serv u nid k rpkt tp)
initServerEnv :: ServerConfig serv
-> IO k
-> (TransportConfig (STP serv) -> TransportConfig tp)
-> (SID serv -> ConnEnv tp -> IO (Maybe (nid, u)))
-> m (ServerEnv serv u nid k rpkt tp)
initServerEnv ServerConfig serv
sc IO k
gen TransportConfig (STP serv) -> TransportConfig tp
mapTransport SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
prepare = do
  serv
serveServ   <- ServerConfig serv -> m serv
forall serv (m :: * -> *).
(Servable serv, MonadIO m) =>
ServerConfig serv -> m serv
newServer ServerConfig serv
sc
  TVar Bool
serveState  <- Bool -> m (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
  IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList <- m (IOHashMap nid (NodeEnv1 u nid k rpkt tp))
forall (m :: * -> *) k v. MonadIO m => m (IOHashMap k v)
HM.empty
  TVar (Maybe (nid -> u -> IO ()))
onNodeLeave <- Maybe (nid -> u -> IO ()) -> m (TVar (Maybe (nid -> u -> IO ())))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (nid -> u -> IO ())
forall a. Maybe a
Nothing
  TVar Int64
keepalive   <- Int64 -> m (TVar Int64)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int64
0
  TVar Int64
defSessTout <- Int64 -> m (TVar Int64)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int64
300
  ServerEnv serv u nid k rpkt tp
-> m (ServerEnv serv u nid k rpkt tp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerEnv :: forall serv u nid k rpkt tp.
serv
-> TVar Bool
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> (SID serv -> ConnEnv tp -> IO (Maybe (nid, u)))
-> IO k
-> TVar Int64
-> TVar Int64
-> NodeMode
-> SessionMode
-> String
-> TVar (Maybe (nid -> u -> IO ()))
-> (TransportConfig (STP serv) -> TransportConfig tp)
-> ServerEnv serv u nid k rpkt tp
ServerEnv
    { nodeMode :: NodeMode
nodeMode    = NodeMode
Multi
    , sessionMode :: SessionMode
sessionMode = SessionMode
SingleAction
    , serveName :: String
serveName   = String
"Metro"
    , serv
IO k
TVar Bool
TVar Int64
TVar (Maybe (nid -> u -> IO ()))
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
TransportConfig (STP serv) -> TransportConfig tp
defSessTout :: TVar Int64
keepalive :: TVar Int64
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
gen :: IO k
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
defSessTout :: TVar Int64
keepalive :: TVar Int64
gen :: IO k
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
..
    }

setNodeMode
  :: NodeMode -> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setNodeMode :: NodeMode
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setNodeMode NodeMode
mode ServerEnv serv u nid k rpkt tp
sEnv = ServerEnv serv u nid k rpkt tp
sEnv {nodeMode :: NodeMode
nodeMode = NodeMode
mode}

setSessionMode
  :: SessionMode -> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setSessionMode :: SessionMode
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setSessionMode SessionMode
mode ServerEnv serv u nid k rpkt tp
sEnv = ServerEnv serv u nid k rpkt tp
sEnv {sessionMode :: SessionMode
sessionMode = SessionMode
mode}

setServerName
  :: String -> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setServerName :: String
-> ServerEnv serv u nid k rpkt tp -> ServerEnv serv u nid k rpkt tp
setServerName String
n ServerEnv serv u nid k rpkt tp
sEnv = ServerEnv serv u nid k rpkt tp
sEnv {serveName :: String
serveName = String
n}

setKeepalive
  :: MonadIO m => ServerEnv serv u nid k rpkt tp -> Int -> m ()
setKeepalive :: ServerEnv serv u nid k rpkt tp -> Int -> m ()
setKeepalive ServerEnv serv u nid k rpkt tp
sEnv =
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (Int -> STM ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64 -> Int64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ServerEnv serv u nid k rpkt tp -> TVar Int64
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive ServerEnv serv u nid k rpkt tp
sEnv) (Int64 -> STM ()) -> (Int -> Int64) -> Int -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

setDefaultSessionTimeout
  :: MonadIO m => ServerEnv serv u nid k rpkt tp -> Int -> m ()
setDefaultSessionTimeout :: ServerEnv serv u nid k rpkt tp -> Int -> m ()
setDefaultSessionTimeout ServerEnv serv u nid k rpkt tp
sEnv =
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (Int -> STM ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64 -> Int64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ServerEnv serv u nid k rpkt tp -> TVar Int64
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
defSessTout ServerEnv serv u nid k rpkt tp
sEnv) (Int64 -> STM ()) -> (Int -> Int64) -> Int -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

setOnNodeLeave :: MonadIO m => ServerEnv serv u nid k rpkt tp -> (nid -> u -> IO ()) -> m ()
setOnNodeLeave :: ServerEnv serv u nid k rpkt tp -> (nid -> u -> IO ()) -> m ()
setOnNodeLeave ServerEnv serv u nid k rpkt tp
sEnv = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((nid -> u -> IO ()) -> STM ()) -> (nid -> u -> IO ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe (nid -> u -> IO ()))
-> Maybe (nid -> u -> IO ()) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
onNodeLeave ServerEnv serv u nid k rpkt tp
sEnv) (Maybe (nid -> u -> IO ()) -> STM ())
-> ((nid -> u -> IO ()) -> Maybe (nid -> u -> IO ()))
-> (nid -> u -> IO ())
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (nid -> u -> IO ()) -> Maybe (nid -> u -> IO ())
forall a. a -> Maybe a
Just

serveForever
  :: (MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid, Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt, Servable serv)
  => (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> ServerT serv u nid k rpkt tp m ()
serveForever :: (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
serveForever rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess = do
  String
name <- (ServerEnv serv u nid k rpkt tp -> String)
-> ServerT serv u nid k rpkt tp m String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerEnv serv u nid k rpkt tp -> String
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> String
serveName
  IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Server started"
  TVar Bool
state <- (ServerEnv serv u nid k rpkt tp -> TVar Bool)
-> ServerT serv u nid k rpkt tp m (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerEnv serv u nid k rpkt tp -> TVar Bool
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Bool
serveState
  (ContT () (ServerT serv u nid k rpkt tp m) ()
-> (() -> ServerT serv u nid k rpkt tp m ())
-> ServerT serv u nid k rpkt tp m ()
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` () -> ServerT serv u nid k rpkt tp m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (ContT () (ServerT serv u nid k rpkt tp m) ()
 -> ServerT serv u nid k rpkt tp m ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ ((() -> ContT () (ServerT serv u nid k rpkt tp m) ())
 -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((() -> ContT () (ServerT serv u nid k rpkt tp m) ())
  -> ContT () (ServerT serv u nid k rpkt tp m) ())
 -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ((() -> ContT () (ServerT serv u nid k rpkt tp m) ())
    -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall a b. (a -> b) -> a -> b
$ \() -> ContT () (ServerT serv u nid k rpkt tp m) ()
exit -> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ContT () (ServerT serv u nid k rpkt tp m) ()
 -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException ()
e <- ServerT serv u nid k rpkt tp m (Either SomeException ())
-> ContT
     () (ServerT serv u nid k rpkt tp m) (Either SomeException ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerT serv u nid k rpkt tp m (Either SomeException ())
 -> ContT
      () (ServerT serv u nid k rpkt tp m) (Either SomeException ()))
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
-> ContT
     () (ServerT serv u nid k rpkt tp m) (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
(rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
tryServeOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess
    Bool
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either SomeException () -> Bool
forall a b. Either a b -> Bool
isLeft Either SomeException ()
e) (ContT () (ServerT serv u nid k rpkt tp m) ()
 -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall a b. (a -> b) -> a -> b
$ () -> ContT () (ServerT serv u nid k rpkt tp m) ()
exit ()
    Bool
alive <- TVar Bool -> ContT () (ServerT serv u nid k rpkt tp m) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
state
    Bool
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alive (ContT () (ServerT serv u nid k rpkt tp m) ()
 -> ContT () (ServerT serv u nid k rpkt tp m) ())
-> ContT () (ServerT serv u nid k rpkt tp m) ()
-> ContT () (ServerT serv u nid k rpkt tp m) ()
forall a b. (a -> b) -> a -> b
$ () -> ContT () (ServerT serv u nid k rpkt tp m) ()
exit ()
  IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Server closed"

tryServeOnce
  :: (MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid, Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt, Servable serv)
  => (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> ServerT serv u nid k rpkt tp m (Either SomeException ())
tryServeOnce :: (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
tryServeOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess = ServerT serv u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny ((rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
(rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
serveOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess)

serveOnce
  :: ( MonadUnliftIO m
     , Transport tp
     , Show nid, Eq nid, Hashable nid
     , Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt
     , Servable serv)
  => (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> ServerT serv u nid k rpkt tp m ()
serveOnce :: (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
serveOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess = do
  ServerEnv {serv
String
IO k
TVar Bool
TVar Int64
TVar (Maybe (nid -> u -> IO ()))
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
SessionMode
NodeMode
SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
TransportConfig (STP serv) -> TransportConfig tp
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
serveName :: String
sessionMode :: SessionMode
nodeMode :: NodeMode
defSessTout :: TVar Int64
keepalive :: TVar Int64
gen :: IO k
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
mapTransport :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
serveName :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> String
sessionMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> SessionMode
nodeMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> NodeMode
defSessTout :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
gen :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> IO k
prepare :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Bool
serveServ :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
..} <- ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
forall r (m :: * -> *). MonadReader r m => m r
ask
  serv
-> (Maybe (SID serv, TransportConfig (STP serv))
    -> ServerT serv u nid k rpkt tp m ())
-> ServerT serv u nid k rpkt tp m ()
forall serv (m :: * -> *).
(Servable serv, MonadUnliftIO m) =>
serv
-> (Maybe (SID serv, TransportConfig (STP serv)) -> m ()) -> m ()
servOnce serv
serveServ ((Maybe (SID serv, TransportConfig (STP serv))
  -> ServerT serv u nid k rpkt tp m ())
 -> ServerT serv u nid k rpkt tp m ())
-> (Maybe (SID serv, TransportConfig (STP serv))
    -> ServerT serv u nid k rpkt tp m ())
-> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> Maybe (SID serv, TransportConfig (STP serv))
-> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
(rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> Maybe (SID serv, TransportConfig (STP serv))
-> ServerT serv u nid k rpkt tp m ()
doServeOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess

doServeOnce
  :: ( MonadUnliftIO m
     , Transport tp
     , Show nid, Eq nid, Hashable nid
     , Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt
     , Servable serv)
  => (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> Maybe (SID serv, TransportConfig (STP serv))
  -> ServerT serv u nid k rpkt tp m ()
doServeOnce :: (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> Maybe (SID serv, TransportConfig (STP serv))
-> ServerT serv u nid k rpkt tp m ()
doServeOnce rpkt -> m Bool
_ SessionT u nid k rpkt tp m ()
_ Maybe (SID serv, TransportConfig (STP serv))
Nothing = () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
doServeOnce rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess (Just (SID serv
servID, TransportConfig (STP serv)
stp)) = do
  ServerEnv {serv
String
IO k
TVar Bool
TVar Int64
TVar (Maybe (nid -> u -> IO ()))
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
SessionMode
NodeMode
SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
TransportConfig (STP serv) -> TransportConfig tp
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
serveName :: String
sessionMode :: SessionMode
nodeMode :: NodeMode
defSessTout :: TVar Int64
keepalive :: TVar Int64
gen :: IO k
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
mapTransport :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
serveName :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> String
sessionMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> SessionMode
nodeMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> NodeMode
defSessTout :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
gen :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> IO k
prepare :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Bool
serveServ :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
..} <- ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
forall r (m :: * -> *). MonadReader r m => m r
ask
  ConnEnv tp
connEnv <- TransportConfig tp -> ServerT serv u nid k rpkt tp m (ConnEnv tp)
forall (m :: * -> *) tp.
(MonadIO m, Transport tp) =>
TransportConfig tp -> m (ConnEnv tp)
initConnEnv (TransportConfig tp -> ServerT serv u nid k rpkt tp m (ConnEnv tp))
-> TransportConfig tp
-> ServerT serv u nid k rpkt tp m (ConnEnv tp)
forall a b. (a -> b) -> a -> b
$ TransportConfig (STP serv) -> TransportConfig tp
mapTransport TransportConfig (STP serv)
stp
  Maybe (nid, u)
mnid <- IO (Maybe (nid, u))
-> ServerT serv u nid k rpkt tp m (Maybe (nid, u))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (nid, u))
 -> ServerT serv u nid k rpkt tp m (Maybe (nid, u)))
-> IO (Maybe (nid, u))
-> ServerT serv u nid k rpkt tp m (Maybe (nid, u))
forall a b. (a -> b) -> a -> b
$ SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
prepare SID serv
servID ConnEnv tp
connEnv
  Maybe (nid, u)
-> ((nid, u) -> ServerT serv u nid k rpkt tp m ())
-> ServerT serv u nid k rpkt tp m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (nid, u)
mnid (((nid, u) -> ServerT serv u nid k rpkt tp m ())
 -> ServerT serv u nid k rpkt tp m ())
-> ((nid, u) -> ServerT serv u nid k rpkt tp m ())
-> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ \(nid
nid, u
uEnv) -> do
    (NodeEnv1 u nid k rpkt tp
_, Async ()
io) <- String
-> SID serv
-> ConnEnv tp
-> nid
-> u
-> (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT
     serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp, Async ())
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
String
-> SID serv
-> ConnEnv tp
-> nid
-> u
-> (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT
     serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp, Async ())
handleConn String
"Client" SID serv
servID ConnEnv tp
connEnv nid
nid u
uEnv rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess
    Either SomeException ()
r <- Async ()
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
forall (m :: * -> *) a.
MonadIO m =>
Async a -> m (Either SomeException a)
waitCatch Async ()
io
    case Either SomeException ()
r of
      Left SomeException
e  -> IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Handle connection error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
      Right ()
_ -> () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleConn
  :: (MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid, Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt, Servable serv)
  => String
  -> SID serv
  -> ConnEnv tp
  -> nid
  -> u
  -> (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> ServerT serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp, Async ())
handleConn :: String
-> SID serv
-> ConnEnv tp
-> nid
-> u
-> (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT
     serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp, Async ())
handleConn String
n SID serv
servID ConnEnv tp
connEnv nid
nid u
uEnv rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess = do
    ServerEnv {serv
String
IO k
TVar Bool
TVar Int64
TVar (Maybe (nid -> u -> IO ()))
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
SessionMode
NodeMode
SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
TransportConfig (STP serv) -> TransportConfig tp
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
serveName :: String
sessionMode :: SessionMode
nodeMode :: NodeMode
defSessTout :: TVar Int64
keepalive :: TVar Int64
gen :: IO k
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
mapTransport :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
serveName :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> String
sessionMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> SessionMode
nodeMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> NodeMode
defSessTout :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
gen :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> IO k
prepare :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Bool
serveServ :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
..} <- ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
forall r (m :: * -> *). MonadReader r m => m r
ask

    IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Metro.Server" (String
serveName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ nid -> String
forall a. Show a => a -> String
show nid
nid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" connected")
    NodeEnv1 u nid k rpkt tp
env0 <- (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> ConnEnv tp
-> u
-> nid
-> IO k
-> ServerT serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp)
forall (m :: * -> *) u nid k rpkt tp.
MonadIO m =>
(NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> ConnEnv tp -> u -> nid -> IO k -> m (NodeEnv1 u nid k rpkt tp)
initEnv1
      (NodeMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
forall u nid k rpkt.
NodeMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
Node.setNodeMode NodeMode
nodeMode
      (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> NodeEnv u nid k rpkt
-> NodeEnv u nid k rpkt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
forall u nid k rpkt.
SessionMode -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
Node.setSessionMode SessionMode
sessionMode
      (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> (NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt)
-> NodeEnv u nid k rpkt
-> NodeEnv u nid k rpkt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64 -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
forall u nid k rpkt.
TVar Int64 -> NodeEnv u nid k rpkt -> NodeEnv u nid k rpkt
Node.setDefaultSessionTimeout TVar Int64
defSessTout) ConnEnv tp
connEnv u
uEnv nid
nid IO k
gen

    Maybe (NodeEnv1 u nid k rpkt tp)
env1 <- STM (Maybe (NodeEnv1 u nid k rpkt tp))
-> ServerT
     serv u nid k rpkt tp m (Maybe (NodeEnv1 u nid k rpkt tp))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (NodeEnv1 u nid k rpkt tp))
 -> ServerT
      serv u nid k rpkt tp m (Maybe (NodeEnv1 u nid k rpkt tp)))
-> STM (Maybe (NodeEnv1 u nid k rpkt tp))
-> ServerT
     serv u nid k rpkt tp m (Maybe (NodeEnv1 u nid k rpkt tp))
forall a b. (a -> b) -> a -> b
$ do
      Maybe (NodeEnv1 u nid k rpkt tp)
v <- nid
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> STM (Maybe (NodeEnv1 u nid k rpkt tp))
forall k v.
(Eq k, Hashable k) =>
k -> IOHashMap k v -> STM (Maybe v)
HMS.lookup nid
nid IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList
      nid
-> NodeEnv1 u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> STM ()
forall k v. (Eq k, Hashable k) => k -> v -> IOHashMap k v -> STM ()
HMS.insert nid
nid NodeEnv1 u nid k rpkt tp
env0 IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList
      Maybe (NodeEnv1 u nid k rpkt tp)
-> STM (Maybe (NodeEnv1 u nid k rpkt tp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NodeEnv1 u nid k rpkt tp)
v

    (NodeEnv1 u nid k rpkt tp -> ServerT serv u nid k rpkt tp m ())
-> Maybe (NodeEnv1 u nid k rpkt tp)
-> ServerT serv u nid k rpkt tp m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeEnv1 u nid k rpkt tp
-> NodeT u nid k rpkt tp (ServerT serv u nid k rpkt tp m) ()
-> ServerT serv u nid k rpkt tp m ()
forall u nid k rpkt tp (m :: * -> *) a.
NodeEnv1 u nid k rpkt tp -> NodeT u nid k rpkt tp m a -> m a
`runNodeT1` NodeT u nid k rpkt tp (ServerT serv u nid k rpkt tp m) ()
forall (m :: * -> *) tp u nid k rpkt.
(MonadIO m, Transport tp) =>
NodeT u nid k rpkt tp m ()
stopNodeT) Maybe (NodeEnv1 u nid k rpkt tp)
env1

    Async ()
io <- ServerT serv u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (ServerT serv u nid k rpkt tp m ()
 -> ServerT serv u nid k rpkt tp m (Async ()))
-> ServerT serv u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m (Async ())
forall a b. (a -> b) -> a -> b
$ do
      serv -> SID serv -> ServerT serv u nid k rpkt tp m ()
forall serv (m :: * -> *).
(Servable serv, MonadIO m) =>
serv -> SID serv -> m ()
onConnEnter serv
serveServ SID serv
servID
      m () -> ServerT serv u nid k rpkt tp m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ServerT serv u nid k rpkt tp m ())
-> (NodeT u nid k rpkt tp m () -> m ())
-> NodeT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeEnv1 u nid k rpkt tp -> NodeT u nid k rpkt tp m () -> m ()
forall u nid k rpkt tp (m :: * -> *) a.
NodeEnv1 u nid k rpkt tp -> NodeT u nid k rpkt tp m a -> m a
runNodeT1 NodeEnv1 u nid k rpkt tp
env0 (NodeT u nid k rpkt tp m () -> ServerT serv u nid k rpkt tp m ())
-> NodeT u nid k rpkt tp m () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m ()
forall (m :: * -> *) tp rpkt k u nid.
(MonadUnliftIO m, Transport tp, RecvPacket rpkt,
 GetPacketId k rpkt, Eq k, Hashable k) =>
(rpkt -> m Bool)
-> SessionT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m ()
startNodeT_ rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess
      serv -> SID serv -> ServerT serv u nid k rpkt tp m ()
forall serv (m :: * -> *).
(Servable serv, MonadIO m) =>
serv -> SID serv -> m ()
onConnLeave serv
serveServ SID serv
servID
      Maybe (nid -> u -> IO ())
nodeLeave <- TVar (Maybe (nid -> u -> IO ()))
-> ServerT serv u nid k rpkt tp m (Maybe (nid -> u -> IO ()))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (nid -> u -> IO ()))
onNodeLeave
      case Maybe (nid -> u -> IO ())
nodeLeave of
        Maybe (nid -> u -> IO ())
Nothing -> () -> ServerT serv u nid k rpkt tp m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just nid -> u -> IO ()
f  -> IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ nid -> u -> IO ()
f nid
nid u
uEnv
      IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Metro.Server" (String
serveName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ nid -> String
forall a. Show a => a -> String
show nid
nid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" disconnected")

    (NodeEnv1 u nid k rpkt tp, Async ())
-> ServerT
     serv u nid k rpkt tp m (NodeEnv1 u nid k rpkt tp, Async ())
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeEnv1 u nid k rpkt tp
env0, Async ()
io)

startServer
  :: (MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid, Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt, Servable serv)
  => ServerEnv serv u nid k rpkt tp
  -> SessionT u nid k rpkt tp m ()
  -> m ()
startServer :: ServerEnv serv u nid k rpkt tp
-> SessionT u nid k rpkt tp m () -> m ()
startServer ServerEnv serv u nid k rpkt tp
sEnv = ServerEnv serv u nid k rpkt tp
-> (rpkt -> m Bool) -> SessionT u nid k rpkt tp m () -> m ()
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
ServerEnv serv u nid k rpkt tp
-> (rpkt -> m Bool) -> SessionT u nid k rpkt tp m () -> m ()
startServer_ ServerEnv serv u nid k rpkt tp
sEnv (m Bool -> rpkt -> m Bool
forall a b. a -> b -> a
const (m Bool -> rpkt -> m Bool) -> m Bool -> rpkt -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

startServer_
  :: (MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid, Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt, Servable serv)
  => ServerEnv serv u nid k rpkt tp
  -> (rpkt -> m Bool)
  -> SessionT u nid k rpkt tp m ()
  -> m ()
startServer_ :: ServerEnv serv u nid k rpkt tp
-> (rpkt -> m Bool) -> SessionT u nid k rpkt tp m () -> m ()
startServer_ ServerEnv serv u nid k rpkt tp
sEnv rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess = do
  TVar Int64 -> IOHashMap nid (NodeEnv1 u nid k rpkt tp) -> m ()
forall (m :: * -> *) nid tp u k rpkt.
(MonadUnliftIO m, Eq nid, Hashable nid, Transport tp) =>
TVar Int64 -> IOHashMap nid (NodeEnv1 u nid k rpkt tp) -> m ()
runCheckNodeState (ServerEnv serv u nid k rpkt tp -> TVar Int64
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive ServerEnv serv u nid k rpkt tp
sEnv) (ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList ServerEnv serv u nid k rpkt tp
sEnv)
  ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m () -> m ()
forall serv u nid k rpkt tp (m :: * -> *) a.
ServerEnv serv u nid k rpkt tp
-> ServerT serv u nid k rpkt tp m a -> m a
runServerT ServerEnv serv u nid k rpkt tp
sEnv (ServerT serv u nid k rpkt tp m () -> m ())
-> ServerT serv u nid k rpkt tp m () -> m ()
forall a b. (a -> b) -> a -> b
$ (rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) tp nid k rpkt serv u.
(MonadUnliftIO m, Transport tp, Show nid, Eq nid, Hashable nid,
 Eq k, Hashable k, GetPacketId k rpkt, RecvPacket rpkt,
 Servable serv) =>
(rpkt -> m Bool)
-> SessionT u nid k rpkt tp m ()
-> ServerT serv u nid k rpkt tp m ()
serveForever rpkt -> m Bool
preprocess SessionT u nid k rpkt tp m ()
sess
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ serv -> IO ()
forall serv (m :: * -> *).
(Servable serv, MonadIO m) =>
serv -> m ()
servClose (serv -> IO ()) -> serv -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerEnv serv u nid k rpkt tp -> serv
forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
serveServ ServerEnv serv u nid k rpkt tp
sEnv

stopServerT :: (MonadIO m, Servable serv) => ServerT serv u nid k rpkt tp m ()
stopServerT :: ServerT serv u nid k rpkt tp m ()
stopServerT = do
  ServerEnv {serv
String
IO k
TVar Bool
TVar Int64
TVar (Maybe (nid -> u -> IO ()))
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
SessionMode
NodeMode
SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
TransportConfig (STP serv) -> TransportConfig tp
mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: TVar (Maybe (nid -> u -> IO ()))
serveName :: String
sessionMode :: SessionMode
nodeMode :: NodeMode
defSessTout :: TVar Int64
keepalive :: TVar Int64
gen :: IO k
prepare :: SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: TVar Bool
serveServ :: serv
mapTransport :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> TransportConfig (STP serv) -> TransportConfig tp
onNodeLeave :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar (Maybe (nid -> u -> IO ()))
serveName :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> String
sessionMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> SessionMode
nodeMode :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> NodeMode
defSessTout :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
keepalive :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Int64
gen :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> IO k
prepare :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> SID serv -> ConnEnv tp -> IO (Maybe (nid, u))
nodeEnvList :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
serveState :: forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp -> TVar Bool
serveServ :: forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
..} <- ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
forall r (m :: * -> *). MonadReader r m => m r
ask
  STM () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ServerT serv u nid k rpkt tp m ())
-> STM () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
serveState Bool
False
  IO () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerT serv u nid k rpkt tp m ())
-> IO () -> ServerT serv u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ serv -> IO ()
forall serv (m :: * -> *).
(Servable serv, MonadIO m) =>
serv -> m ()
servClose serv
serveServ

runCheckNodeState
  :: (MonadUnliftIO m, Eq nid, Hashable nid, Transport tp)
  => TVar Int64 -> IOHashMap nid (NodeEnv1 u nid k rpkt tp) -> m ()
runCheckNodeState :: TVar Int64 -> IOHashMap nid (NodeEnv1 u nid k rpkt tp) -> m ()
runCheckNodeState TVar Int64
alive IOHashMap nid (NodeEnv1 u nid k rpkt tp)
envList = m (Async Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async Any) -> m ()) -> (m () -> m (Async Any)) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Any -> m (Async Any)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m Any -> m (Async Any))
-> (m () -> m Any) -> m () -> m (Async Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Int64
t <- TVar Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
alive
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
t Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
    (NodeEnv1 u nid k rpkt tp -> m ())
-> [NodeEnv1 u nid k rpkt tp] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> NodeEnv1 u nid k rpkt tp -> m ()
forall (m :: * -> *) nid tp u k rpkt.
(MonadUnliftIO m, Eq nid, Hashable nid, Transport tp) =>
IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> NodeEnv1 u nid k rpkt tp -> m ()
checkAlive IOHashMap nid (NodeEnv1 u nid k rpkt tp)
envList) ([NodeEnv1 u nid k rpkt tp] -> m ())
-> m [NodeEnv1 u nid k rpkt tp] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> m [NodeEnv1 u nid k rpkt tp]
forall (m :: * -> *) k v. MonadIO m => IOHashMap k v -> m [v]
HM.elems IOHashMap nid (NodeEnv1 u nid k rpkt tp)
envList

  where checkAlive
          :: (MonadUnliftIO m, Eq nid, Hashable nid, Transport tp)
          => IOHashMap nid (NodeEnv1 u nid k rpkt tp)
          -> NodeEnv1 u nid k rpkt tp -> m ()
        checkAlive :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> NodeEnv1 u nid k rpkt tp -> m ()
checkAlive IOHashMap nid (NodeEnv1 u nid k rpkt tp)
ref NodeEnv1 u nid k rpkt tp
env1 = NodeEnv1 u nid k rpkt tp -> NodeT u nid k rpkt tp m () -> m ()
forall u nid k rpkt tp (m :: * -> *) a.
NodeEnv1 u nid k rpkt tp -> NodeT u nid k rpkt tp m a -> m a
runNodeT1 NodeEnv1 u nid k rpkt tp
env1 (NodeT u nid k rpkt tp m () -> m ())
-> NodeT u nid k rpkt tp m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              Int64
t <- TVar Int64 -> NodeT u nid k rpkt tp m Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
alive
              Int64
expiredAt <- (Int64
t Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+) (Int64 -> Int64)
-> NodeT u nid k rpkt tp m Int64 -> NodeT u nid k rpkt tp m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeT u nid k rpkt tp m Int64
forall (m :: * -> *) u nid k rpkt tp.
MonadIO m =>
NodeT u nid k rpkt tp m Int64
getTimer
              Int64
now <- NodeT u nid k rpkt tp m Int64
forall (m :: * -> *). MonadIO m => m Int64
getEpochTime
              Bool -> NodeT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
now Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
expiredAt) (NodeT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m ())
-> NodeT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m ()
forall a b. (a -> b) -> a -> b
$ do
                nid
nid <- NodeT u nid k rpkt tp m nid
forall (m :: * -> *) n nid k rpkt tp.
Monad m =>
NodeT n nid k rpkt tp m nid
getNodeId
                NodeT u nid k rpkt tp m ()
forall (m :: * -> *) tp u nid k rpkt.
(MonadIO m, Transport tp) =>
NodeT u nid k rpkt tp m ()
stopNodeT
                nid
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> NodeT u nid k rpkt tp m ()
forall (m :: * -> *) k v.
(MonadIO m, Eq k, Hashable k) =>
k -> IOHashMap k v -> m ()
HM.delete nid
nid IOHashMap nid (NodeEnv1 u nid k rpkt tp)
ref

serverEnv :: Monad m => ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
serverEnv :: ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
serverEnv = ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp)
forall r (m :: * -> *). MonadReader r m => m r
ask

getNodeEnvList :: ServerEnv serv u nid k rpkt tp -> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
getNodeEnvList :: ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
getNodeEnvList = ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
forall serv u nid k rpkt tp.
ServerEnv serv u nid k rpkt tp
-> IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList

getServ :: ServerEnv serv u nid k rpkt tp -> serv
getServ :: ServerEnv serv u nid k rpkt tp -> serv
getServ = ServerEnv serv u nid k rpkt tp -> serv
forall serv u nid k rpkt tp. ServerEnv serv u nid k rpkt tp -> serv
serveServ