{-# 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, mzero, unless,
                                             void, when)
import           Control.Monad.Reader.Class (MonadReader (ask), asks)
import           Control.Monad.Trans.Class  (MonadTrans, lift)
import           Control.Monad.Trans.Maybe  (runMaybeT)
import           Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
import           Data.Either                (isLeft)
import           Data.Hashable
import           Data.Int                   (Int64)
import           Metro.Class                (GetPacketId, RecvPacket,
                                             Servable (..), Transport,
                                             TransportConfig)
import           Metro.Conn                 hiding (close)
import           Metro.IOHashMap            (IOHashMap, newIOHashMap)
import qualified Metro.IOHashMap            as HM (delete, elems, insertSTM,
                                                   lookupSTM)
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 inner :: (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
$ \r :: 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
$ \run :: 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 sEnv :: 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 sc :: ServerConfig serv
sc gen :: IO k
gen mapTransport :: TransportConfig (STP serv) -> TransportConfig tp
mapTransport prepare :: 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 :: * -> *) a b. MonadIO m => m (IOHashMap a b)
newIOHashMap
  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 0
  TVar Int64
defSessTout <- Int64 -> m (TVar Int64)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO 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   = "Metro"
    , ..
    }

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 mode :: NodeMode
mode sEnv :: 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 mode :: SessionMode
mode sEnv :: 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 n :: String
n sEnv :: 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 sEnv :: 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 sEnv :: 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 sEnv :: 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 preprocess :: rpkt -> m Bool
preprocess sess :: 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 "Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
  ServerT serv u nid k rpkt tp m (Maybe Any)
-> ServerT serv u nid k rpkt tp m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ServerT serv u nid k rpkt tp m (Maybe Any)
 -> ServerT serv u nid k rpkt tp m ())
-> (MaybeT (ServerT serv u nid k rpkt tp m) ()
    -> ServerT serv u nid k rpkt tp m (Maybe Any))
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
-> ServerT serv u nid k rpkt tp m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (ServerT serv u nid k rpkt tp m) Any
-> ServerT serv u nid k rpkt tp m (Maybe Any)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ServerT serv u nid k rpkt tp m) Any
 -> ServerT serv u nid k rpkt tp m (Maybe Any))
-> (MaybeT (ServerT serv u nid k rpkt tp m) ()
    -> MaybeT (ServerT serv u nid k rpkt tp m) Any)
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
-> ServerT serv u nid k rpkt tp m (Maybe Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (ServerT serv u nid k rpkt tp m) ()
-> MaybeT (ServerT serv u nid k rpkt tp m) Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (MaybeT (ServerT serv u nid k rpkt tp m) ()
 -> ServerT serv u nid k rpkt tp m ())
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
-> 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 ())
-> MaybeT
     (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 ())
 -> MaybeT
      (ServerT serv u nid k rpkt tp m) (Either SomeException ()))
-> ServerT serv u nid k rpkt tp m (Either SomeException ())
-> MaybeT
     (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
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
-> MaybeT (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) MaybeT (ServerT serv u nid k rpkt tp m) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Bool
alive <- TVar Bool -> MaybeT (ServerT serv u nid k rpkt tp m) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
state
    Bool
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
-> MaybeT (ServerT serv u nid k rpkt tp m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alive MaybeT (ServerT serv u nid k rpkt tp m) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  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 "Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 preprocess :: rpkt -> m Bool
preprocess sess :: 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 preprocess :: rpkt -> m Bool
preprocess sess :: SessionT u nid k rpkt tp m ()
sess = do
  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
  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 _ _ Nothing = () -> ServerT serv u nid k rpkt tp m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
doServeOnce preprocess :: rpkt -> m Bool
preprocess sess :: SessionT u nid k rpkt tp m ()
sess (Just (servID :: SID serv
servID, stp :: TransportConfig (STP serv)
stp)) = do
  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
  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
nid, uEnv :: u
uEnv) -> do
    (_, io :: 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 "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 e :: 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 "Metro.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 n :: String
n servID :: SID serv
servID connEnv :: ConnEnv tp
connEnv nid :: nid
nid uEnv :: u
uEnv preprocess :: rpkt -> m Bool
preprocess sess :: SessionT u nid k rpkt tp m ()
sess = do
    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

    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 "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
forall a. [a] -> [a] -> [a]
++ nid -> String
forall a. Show a => a -> String
show nid
nid String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 <- IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> nid -> STM (Maybe (NodeEnv1 u nid k rpkt tp))
forall a b.
(Eq a, Hashable a) =>
IOHashMap a b -> a -> STM (Maybe b)
HM.lookupSTM IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList nid
nid
      IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> nid -> NodeEnv1 u nid k rpkt tp -> STM ()
forall a b. (Eq a, Hashable a) => IOHashMap a b -> a -> b -> STM ()
HM.insertSTM IOHashMap nid (NodeEnv1 u nid k rpkt tp)
nodeEnvList nid
nid NodeEnv1 u nid k rpkt tp
env0
      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
        Nothing -> () -> ServerT serv u nid k rpkt tp m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just f :: 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 "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
forall a. [a] -> [a] -> [a]
++ nid -> String
forall a. Show a => a -> String
show nid
nid String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 sEnv :: 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_ sEnv :: ServerEnv serv u nid k rpkt tp
sEnv preprocess :: rpkt -> m Bool
preprocess sess :: 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 {..} <- 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 alive :: TVar Int64
alive envList :: 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
> 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
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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 :: * -> *) a b. MonadIO m => IOHashMap a b -> m [b]
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 ref :: IOHashMap nid (NodeEnv1 u nid k rpkt tp)
ref env1 :: 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
                IOHashMap nid (NodeEnv1 u nid k rpkt tp)
-> nid -> NodeT u nid k rpkt tp m ()
forall a (m :: * -> *) b.
(Eq a, Hashable a, MonadIO m) =>
IOHashMap a b -> a -> m ()
HM.delete IOHashMap nid (NodeEnv1 u nid k rpkt tp)
ref nid
nid

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