module Game.LambdaHack.Server.ProtocolM
(
CliSerQueue, ConnServerDict, ChanServer(..)
, MonadServerComm
( getsDict
, modifyDict
, liftIO
)
, putDict, sendUpdate, sendUpdateCheck, sendUpdNoState
, sendSfx, sendQueryAI, sendQueryUI
, killAllClients, childrenServer, updateConn, tryRestore
#ifdef EXPOSE_INTERNAL
, writeQueue, readQueueAI, readQueueUI, newQueue
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM, mapWithKeyM_)
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (RequestAI, RequestUI, Response (..))
import Game.LambdaHack.Common.ClientOptions (sbenchmark)
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.File
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Thread
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.DebugM
import Game.LambdaHack.Server.MonadServer hiding (liftIO)
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
writeQueue :: MonadServerComm m
=> Response -> CliSerQueue Response -> m ()
{-# INLINE writeQueue #-}
writeQueue :: Response -> CliSerQueue Response -> m ()
writeQueue Response
cmd CliSerQueue Response
responseS = IO () -> m ()
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CliSerQueue Response -> Response -> IO ()
forall a. MVar a -> a -> IO ()
putMVar CliSerQueue Response
responseS Response
cmd
readQueueAI :: MonadServerComm m
=> CliSerQueue RequestAI -> m RequestAI
{-# INLINE readQueueAI #-}
readQueueAI :: CliSerQueue RequestAI -> m RequestAI
readQueueAI CliSerQueue RequestAI
requestS = IO RequestAI -> m RequestAI
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO RequestAI -> m RequestAI) -> IO RequestAI -> m RequestAI
forall a b. (a -> b) -> a -> b
$ CliSerQueue RequestAI -> IO RequestAI
forall a. MVar a -> IO a
takeMVar CliSerQueue RequestAI
requestS
readQueueUI :: MonadServerComm m
=> CliSerQueue RequestUI -> m RequestUI
{-# INLINE readQueueUI #-}
readQueueUI :: CliSerQueue RequestUI -> m RequestUI
readQueueUI CliSerQueue RequestUI
requestS = IO RequestUI -> m RequestUI
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO RequestUI -> m RequestUI) -> IO RequestUI -> m RequestUI
forall a b. (a -> b) -> a -> b
$ CliSerQueue RequestUI -> IO RequestUI
forall a. MVar a -> IO a
takeMVar CliSerQueue RequestUI
requestS
newQueue :: IO (CliSerQueue a)
newQueue :: IO (CliSerQueue a)
newQueue = IO (CliSerQueue a)
forall a. IO (MVar a)
newEmptyMVar
type CliSerQueue = MVar
type ConnServerDict = EM.EnumMap FactionId ChanServer
data ChanServer = ChanServer
{ ChanServer -> CliSerQueue Response
responseS :: CliSerQueue Response
, ChanServer -> CliSerQueue RequestAI
requestAIS :: CliSerQueue RequestAI
, ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS :: Maybe (CliSerQueue RequestUI)
}
class MonadServer m => MonadServerComm m where
getsDict :: (ConnServerDict -> a) -> m a
modifyDict :: (ConnServerDict -> ConnServerDict) -> m ()
liftIO :: IO a -> m a
getDict :: MonadServerComm m => m ConnServerDict
getDict :: m ConnServerDict
getDict = (ConnServerDict -> ConnServerDict) -> m ConnServerDict
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict ConnServerDict -> ConnServerDict
forall a. a -> a
id
putDict :: MonadServerComm m => ConnServerDict -> m ()
putDict :: ConnServerDict -> m ()
putDict ConnServerDict
s = (ConnServerDict -> ConnServerDict) -> m ()
forall (m :: * -> *).
MonadServerComm m =>
(ConnServerDict -> ConnServerDict) -> m ()
modifyDict (ConnServerDict -> ConnServerDict -> ConnServerDict
forall a b. a -> b -> a
const ConnServerDict
s)
sendUpdate :: (MonadServerAtomic m, MonadServerComm m)
=> FactionId -> UpdAtomic -> m ()
sendUpdate :: FactionId -> UpdAtomic -> m ()
sendUpdate !FactionId
fid !UpdAtomic
cmd = do
Bool
succeeded <- FactionId -> UpdAtomic -> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> UpdAtomic -> m Bool
execUpdAtomicFidCatch FactionId
fid UpdAtomic
cmd
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
succeeded (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpd FactionId
fid UpdAtomic
cmd
sendUpdateCheck :: (MonadServerAtomic m, MonadServerComm m)
=> FactionId -> UpdAtomic -> m ()
sendUpdateCheck :: FactionId -> UpdAtomic -> m ()
sendUpdateCheck !FactionId
fid !UpdAtomic
cmd = do
FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> UpdAtomic -> m ()
execUpdAtomicFid FactionId
fid UpdAtomic
cmd
FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpd FactionId
fid UpdAtomic
cmd
sendUpd :: MonadServerComm m => FactionId -> UpdAtomic -> m ()
sendUpd :: FactionId -> UpdAtomic -> m ()
sendUpd !FactionId
fid !UpdAtomic
cmd = do
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
State
s <- (StateServer -> State) -> m State
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> State) -> m State)
-> (StateServer -> State) -> m State
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId State -> State)
-> (StateServer -> EnumMap FactionId State) -> StateServer -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap FactionId State
sclientStates
let resp :: Response
resp = State -> UpdAtomic -> Response
RespUpdAtomic State
s UpdAtomic
cmd
Bool
debug <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Response -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
resp
Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
resp (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
sendUpdNoState :: MonadServerComm m => FactionId -> UpdAtomic -> m ()
sendUpdNoState :: FactionId -> UpdAtomic -> m ()
sendUpdNoState !FactionId
fid !UpdAtomic
cmd = do
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
let resp :: Response
resp = UpdAtomic -> Response
RespUpdAtomicNoState UpdAtomic
cmd
Bool
debug <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Response -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
resp
Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
resp (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
sendSfx :: MonadServerComm m => FactionId -> SfxAtomic -> m ()
sendSfx :: FactionId -> SfxAtomic -> m ()
sendSfx !FactionId
fid !SfxAtomic
sfx = do
let resp :: Response
resp = SfxAtomic -> Response
RespSfxAtomic SfxAtomic
sfx
Bool
debug <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Response -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
resp
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
case ChanServer
chan of
ChanServer{requestUIS :: ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS=Just{}} -> Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
resp (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
ChanServer
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI
sendQueryAI :: FactionId -> ActorId -> m RequestAI
sendQueryAI FactionId
fid ActorId
aid = do
let respAI :: Response
respAI = ActorId -> Response
RespQueryAI ActorId
aid
Bool
debug <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Response -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
respAI
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
RequestAI
req <- do
Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
respAI (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
CliSerQueue RequestAI -> m RequestAI
forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestAI -> m RequestAI
readQueueAI (CliSerQueue RequestAI -> m RequestAI)
-> CliSerQueue RequestAI -> m RequestAI
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue RequestAI
requestAIS ChanServer
chan
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> m ()
forall (m :: * -> *). MonadServer m => ActorId -> m ()
debugRequestAI ActorId
aid
RequestAI -> m RequestAI
forall (m :: * -> *) a. Monad m => a -> m a
return RequestAI
req
sendQueryUI :: (MonadServerAtomic m, MonadServerComm m)
=> Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI :: Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI Response
respUI FactionId
fid ActorId
_aid = do
Bool
debug <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Response -> m ()
forall (m :: * -> *).
MonadServer m =>
FactionId -> Response -> m ()
debugResponse FactionId
fid Response
respUI
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
RequestUI
req <- do
Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
respUI (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
CliSerQueue RequestUI -> m RequestUI
forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestUI -> m RequestUI
readQueueUI (CliSerQueue RequestUI -> m RequestUI)
-> CliSerQueue RequestUI -> m RequestUI
forall a b. (a -> b) -> a -> b
$ Maybe (CliSerQueue RequestUI) -> CliSerQueue RequestUI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CliSerQueue RequestUI) -> CliSerQueue RequestUI)
-> Maybe (CliSerQueue RequestUI) -> CliSerQueue RequestUI
forall a b. (a -> b) -> a -> b
$ ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS ChanServer
chan
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> m ()
forall (m :: * -> *). MonadServer m => ActorId -> m ()
debugRequestUI ActorId
_aid
RequestUI -> m RequestUI
forall (m :: * -> *) a. Monad m => a -> m a
return RequestUI
req
killAllClients :: (MonadServerAtomic m, MonadServerComm m) => m ()
killAllClients :: m ()
killAllClients = do
ConnServerDict
d <- m ConnServerDict
forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict
let sendKill :: FactionId -> p -> m ()
sendKill FactionId
fid p
_ = FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpdNoState FactionId
fid (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> UpdAtomic
UpdKillExit FactionId
fid
(Key (EnumMap FactionId) -> ChanServer -> m ())
-> ConnServerDict -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(FoldableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m ()
mapWithKeyM_ Key (EnumMap FactionId) -> ChanServer -> m ()
forall (m :: * -> *) p. MonadServerComm m => FactionId -> p -> m ()
sendKill ConnServerDict
d
childrenServer :: MVar [Async ()]
{-# NOINLINE childrenServer #-}
childrenServer :: MVar [Async ()]
childrenServer = IO (MVar [Async ()]) -> MVar [Async ()]
forall a. IO a -> a
unsafePerformIO ([Async ()] -> IO (MVar [Async ()])
forall a. a -> IO (MVar a)
newMVar [])
updateConn :: (MonadServerAtomic m, MonadServerComm m)
=> (Bool -> FactionId -> ChanServer -> IO ())
-> m ()
updateConn :: (Bool -> FactionId -> ChanServer -> IO ()) -> m ()
updateConn Bool -> FactionId -> ChanServer -> IO ()
executorClient = do
ConnServerDict
oldD <- m ConnServerDict
forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict
let mkChanServer :: Faction -> IO ChanServer
mkChanServer :: Faction -> IO ChanServer
mkChanServer Faction
fact = do
CliSerQueue Response
responseS <- IO (CliSerQueue Response)
forall a. IO (MVar a)
newQueue
CliSerQueue RequestAI
requestAIS <- IO (CliSerQueue RequestAI)
forall a. IO (MVar a)
newQueue
Maybe (CliSerQueue RequestUI)
requestUIS <- if Player -> Bool
fhasUI (Player -> Bool) -> Player -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Player
gplayer Faction
fact
then CliSerQueue RequestUI -> Maybe (CliSerQueue RequestUI)
forall a. a -> Maybe a
Just (CliSerQueue RequestUI -> Maybe (CliSerQueue RequestUI))
-> IO (CliSerQueue RequestUI) -> IO (Maybe (CliSerQueue RequestUI))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (CliSerQueue RequestUI)
forall a. IO (MVar a)
newQueue
else Maybe (CliSerQueue RequestUI) -> IO (Maybe (CliSerQueue RequestUI))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (CliSerQueue RequestUI)
forall a. Maybe a
Nothing
ChanServer -> IO ChanServer
forall (m :: * -> *) a. Monad m => a -> m a
return (ChanServer -> IO ChanServer) -> ChanServer -> IO ChanServer
forall a b. (a -> b) -> a -> b
$! ChanServer :: CliSerQueue Response
-> CliSerQueue RequestAI
-> Maybe (CliSerQueue RequestUI)
-> ChanServer
ChanServer{Maybe (CliSerQueue RequestUI)
CliSerQueue RequestAI
CliSerQueue Response
requestUIS :: Maybe (CliSerQueue RequestUI)
requestAIS :: CliSerQueue RequestAI
responseS :: CliSerQueue Response
requestUIS :: Maybe (CliSerQueue RequestUI)
requestAIS :: CliSerQueue RequestAI
responseS :: CliSerQueue Response
..}
addConn :: FactionId -> Faction -> IO ChanServer
addConn :: FactionId -> Faction -> IO ChanServer
addConn FactionId
fid Faction
fact = case FactionId -> ConnServerDict -> Maybe ChanServer
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup FactionId
fid ConnServerDict
oldD of
Just ChanServer
conns -> ChanServer -> IO ChanServer
forall (m :: * -> *) a. Monad m => a -> m a
return ChanServer
conns
Maybe ChanServer
Nothing | FactionId -> Int
forall a. Enum a => a -> Int
fromEnum FactionId
fid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> Faction -> IO ChanServer
mkChanServer Faction
fact
Maybe ChanServer
Nothing -> case ((FactionId, ChanServer) -> Bool)
-> [(FactionId, ChanServer)] -> [(FactionId, ChanServer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FactionId
fidOld, ChanServer
_) -> FactionId -> Int
forall a. Enum a => a -> Int
fromEnum FactionId
fidOld Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
([(FactionId, ChanServer)] -> [(FactionId, ChanServer)])
-> [(FactionId, ChanServer)] -> [(FactionId, ChanServer)]
forall a b. (a -> b) -> a -> b
$ ConnServerDict -> [(FactionId, ChanServer)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ConnServerDict
oldD of
[] -> Faction -> IO ChanServer
mkChanServer Faction
fact
(FactionId
_, ChanServer
conns) : [(FactionId, ChanServer)]
_ -> ChanServer -> IO ChanServer
forall (m :: * -> *) a. Monad m => a -> m a
return ChanServer
conns
FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
ConnServerDict
d <- IO ConnServerDict -> m ConnServerDict
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO ConnServerDict -> m ConnServerDict)
-> IO ConnServerDict -> m ConnServerDict
forall a b. (a -> b) -> a -> b
$ (Key (EnumMap FactionId) -> Faction -> IO ChanServer)
-> FactionDict -> IO ConnServerDict
forall (t :: * -> *) (m :: * -> *) a b.
(TraversableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m (t b)
mapWithKeyM Key (EnumMap FactionId) -> Faction -> IO ChanServer
FactionId -> Faction -> IO ChanServer
addConn FactionDict
factionD
let newD :: ConnServerDict
newD = ConnServerDict
d ConnServerDict -> ConnServerDict -> ConnServerDict
forall k a. EnumMap k a -> EnumMap k a -> EnumMap k a
`EM.union` ConnServerDict
oldD
ConnServerDict -> m ()
forall (m :: * -> *). MonadServerComm m => ConnServerDict -> m ()
putDict ConnServerDict
newD
let toSpawn :: ConnServerDict
toSpawn = ConnServerDict
newD ConnServerDict -> ConnServerDict -> ConnServerDict
forall k a b. EnumMap k a -> EnumMap k b -> EnumMap k a
EM.\\ ConnServerDict
oldD
forkUI :: FactionId -> ChanServer -> IO ()
forkUI FactionId
fid ChanServer
connS =
MVar [Async ()] -> IO () -> IO ()
forkChild MVar [Async ()]
childrenServer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FactionId -> ChanServer -> IO ()
executorClient Bool
True FactionId
fid ChanServer
connS
forkAI :: FactionId -> ChanServer -> IO ()
forkAI FactionId
fid ChanServer
connS =
MVar [Async ()] -> IO () -> IO ()
forkChild MVar [Async ()]
childrenServer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FactionId -> ChanServer -> IO ()
executorClient Bool
False FactionId
fid ChanServer
connS
forkClient :: FactionId -> ChanServer -> IO ()
forkClient FactionId
fid conn :: ChanServer
conn@ChanServer{requestUIS :: ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS=Maybe (CliSerQueue RequestUI)
Nothing} =
FactionId -> ChanServer -> IO ()
forkAI FactionId
fid ChanServer
conn
forkClient FactionId
fid ChanServer
conn = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnServerDict -> Bool
forall k a. EnumMap k a -> Bool
EM.null ConnServerDict
oldD) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FactionId -> ChanServer -> IO ()
forkUI FactionId
fid ChanServer
conn
IO () -> m ()
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Key (EnumMap FactionId) -> ChanServer -> IO ())
-> ConnServerDict -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(FoldableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m ()
mapWithKeyM_ Key (EnumMap FactionId) -> ChanServer -> IO ()
FactionId -> ChanServer -> IO ()
forkClient ConnServerDict
toSpawn
tryRestore :: MonadServerComm m => m (Maybe (State, StateServer))
tryRestore :: m (Maybe (State, StateServer))
tryRestore = do
COps{RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
ServerOptions
soptions <- (StateServer -> ServerOptions) -> m ServerOptions
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptions
if ClientOptions -> Bool
sbenchmark (ClientOptions -> Bool) -> ClientOptions -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> ClientOptions
sclientOptions ServerOptions
soptions then Maybe (State, StateServer) -> m (Maybe (State, StateServer))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (State, StateServer)
forall a. Maybe a
Nothing
else do
let prefix :: String
prefix = ServerOptions -> String
ssavePrefixSer ServerOptions
soptions
fileName :: String
fileName = String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RuleContent -> String
Save.saveNameSer RuleContent
corule
Maybe (State, StateServer)
res <- IO (Maybe (State, StateServer)) -> m (Maybe (State, StateServer))
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO (Maybe (State, StateServer)) -> m (Maybe (State, StateServer)))
-> IO (Maybe (State, StateServer))
-> m (Maybe (State, StateServer))
forall a b. (a -> b) -> a -> b
$ RuleContent
-> ClientOptions -> String -> IO (Maybe (State, StateServer))
forall a.
Binary a =>
RuleContent -> ClientOptions -> String -> IO (Maybe a)
Save.restoreGame RuleContent
corule (ServerOptions -> ClientOptions
sclientOptions ServerOptions
soptions) String
fileName
let cfgUIName :: String
cfgUIName = RuleContent -> String
rcfgUIName RuleContent
corule
(String
configString, Config
_) = RuleContent -> (String, Config)
rcfgUIDefault RuleContent
corule
String
dataDir <- IO String -> m String
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO IO String
appDataDir
IO () -> m ()
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
tryWriteFile (String
dataDir String -> String -> String
</> String
cfgUIName) String
configString
Maybe (State, StateServer) -> m (Maybe (State, StateServer))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (State, StateServer) -> m (Maybe (State, StateServer)))
-> Maybe (State, StateServer) -> m (Maybe (State, StateServer))
forall a b. (a -> b) -> a -> b
$! Maybe (State, StateServer)
res