module Game.LambdaHack.Server.ProtocolM
(
CliSerQueue, ConnServerDict, ChanServer(..)
, MonadServerComm
( getsDict
, putDict
, liftIO
)
, 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_)
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.FactionKind
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 :: forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
cmd CliSerQueue Response
responseS = IO () -> m ()
forall a. IO a -> m a
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 :: forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestAI -> m RequestAI
readQueueAI CliSerQueue RequestAI
requestS = IO RequestAI -> m RequestAI
forall a. IO a -> m a
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 :: forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestUI -> m RequestUI
readQueueUI CliSerQueue RequestUI
requestS = IO RequestUI -> m RequestUI
forall a. IO a -> m a
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 :: forall a. IO (CliSerQueue a)
newQueue = IO (MVar a)
forall a. IO (CliSerQueue 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
putDict :: ConnServerDict -> m ()
liftIO :: IO a -> m a
getDict :: MonadServerComm m => m ConnServerDict
getDict :: forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict = (ConnServerDict -> ConnServerDict) -> m ConnServerDict
forall a. (ConnServerDict -> a) -> m a
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict ConnServerDict -> ConnServerDict
forall a. a -> a
id
sendUpdate :: (MonadServerAtomic m, MonadServerComm m)
=> FactionId -> UpdAtomic -> m ()
sendUpdate :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
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 :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
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 :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpd !FactionId
fid !UpdAtomic
cmd = do
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall a. (ConnServerDict -> a) -> m a
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 a. (StateServer -> a) -> m a
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 a. (StateServer -> a) -> m a
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 :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpdNoState !FactionId
fid !UpdAtomic
cmd = do
ChanServer
chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall a. (ConnServerDict -> a) -> m a
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 a. (StateServer -> a) -> m a
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 :: forall (m :: * -> *).
MonadServerComm m =>
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 a. (StateServer -> a) -> m a
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 a. (ConnServerDict -> a) -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI
sendQueryAI :: forall (m :: * -> *).
MonadServerComm m =>
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 a. (StateServer -> a) -> m a
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 a. (ConnServerDict -> a) -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestAI
req
sendQueryUI :: (MonadServerAtomic m, MonadServerComm m)
=> Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI Response
respUI FactionId
fid ActorId
_aid = do
Bool
debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
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 a. (ConnServerDict -> a) -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestUI
req
killAllClients :: (MonadServerAtomic m, MonadServerComm m) => m ()
killAllClients :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
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 ()
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)
=> (FactionId -> ChanServer -> IO ())
-> m ()
updateConn :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
(FactionId -> ChanServer -> IO ()) -> m ()
updateConn 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 (CliSerQueue a)
newQueue
CliSerQueue RequestAI
requestAIS <- IO (CliSerQueue RequestAI)
forall a. IO (CliSerQueue a)
newQueue
Maybe (CliSerQueue RequestUI)
requestUIS <- if FactionKind -> Bool
fhasUI (FactionKind -> Bool) -> FactionKind -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact
then Bool
-> IO (Maybe (CliSerQueue RequestUI))
-> IO (Maybe (CliSerQueue RequestUI))
forall a. HasCallStack => Bool -> a -> a
assert (ConnServerDict -> Bool
forall k a. EnumMap k a -> Bool
EM.null ConnServerDict
oldD) (IO (Maybe (CliSerQueue RequestUI))
-> IO (Maybe (CliSerQueue RequestUI)))
-> IO (Maybe (CliSerQueue RequestUI))
-> IO (Maybe (CliSerQueue RequestUI))
forall a b. (a -> b) -> a -> b
$ 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 (CliSerQueue a)
newQueue
else Maybe (CliSerQueue RequestUI) -> IO (Maybe (CliSerQueue RequestUI))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (CliSerQueue RequestUI)
forall a. Maybe a
Nothing
ChanServer -> IO ChanServer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ChanServer{Maybe (CliSerQueue RequestUI)
CliSerQueue RequestAI
CliSerQueue Response
responseS :: CliSerQueue Response
requestAIS :: CliSerQueue RequestAI
requestUIS :: Maybe (CliSerQueue RequestUI)
responseS :: CliSerQueue Response
requestAIS :: CliSerQueue RequestAI
requestUIS :: Maybe (CliSerQueue RequestUI)
..}
forkClient :: FactionId -> ChanServer -> IO ()
forkClient FactionId
fid = MVar [Async ()] -> IO () -> IO ()
forkChild MVar [Async ()]
childrenServer (IO () -> IO ()) -> (ChanServer -> IO ()) -> ChanServer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> ChanServer -> IO ()
executorClient FactionId
fid
FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
if ConnServerDict -> Bool
forall k a. EnumMap k a -> Bool
EM.null ConnServerDict
oldD then do
ConnServerDict
newD <- IO ConnServerDict -> m ConnServerDict
forall a. IO a -> m a
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
$ (Faction -> IO ChanServer) -> FactionDict -> IO ConnServerDict
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EnumMap FactionId a -> m (EnumMap FactionId b)
mapM Faction -> IO ChanServer
mkChanServer FactionDict
factionD
ConnServerDict -> m ()
forall (m :: * -> *). MonadServerComm m => ConnServerDict -> m ()
putDict ConnServerDict
newD
IO () -> m ()
forall a. IO a -> m a
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
newD
else do
let
(FactionId
fidUI, Faction
_) = Maybe (FactionId, Faction) -> (FactionId, Faction)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (FactionId, Faction) -> (FactionId, Faction))
-> Maybe (FactionId, Faction) -> (FactionId, Faction)
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> Maybe (FactionId, Faction)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (FactionKind -> Bool
fhasUI (FactionKind -> Bool)
-> ((FactionId, Faction) -> FactionKind)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> FactionKind
gkind (Faction -> FactionKind)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> FactionKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) ([(FactionId, Faction)] -> Maybe (FactionId, Faction))
-> [(FactionId, Faction)] -> Maybe (FactionId, Faction)
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD
swappedD :: ConnServerDict
swappedD = case ((FactionId, ChanServer) -> Bool)
-> [(FactionId, ChanServer)] -> Maybe (FactionId, ChanServer)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Maybe (CliSerQueue RequestUI) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CliSerQueue RequestUI) -> Bool)
-> ((FactionId, ChanServer) -> Maybe (CliSerQueue RequestUI))
-> (FactionId, ChanServer)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS (ChanServer -> Maybe (CliSerQueue RequestUI))
-> ((FactionId, ChanServer) -> ChanServer)
-> (FactionId, ChanServer)
-> Maybe (CliSerQueue RequestUI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, ChanServer) -> ChanServer
forall a b. (a, b) -> b
snd)
([(FactionId, ChanServer)] -> Maybe (FactionId, ChanServer))
-> [(FactionId, ChanServer)] -> Maybe (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
Maybe (FactionId, ChanServer)
Nothing -> [Char] -> ConnServerDict
forall a. HasCallStack => [Char] -> a
error [Char]
"updateConn: no UI connection found"
Just (FactionId
fid, ChanServer
conn) ->
if FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fidUI
then ConnServerDict
oldD
else let
alt :: Maybe ChanServer -> Maybe ChanServer
alt Maybe ChanServer
_ = FactionId -> ConnServerDict -> Maybe ChanServer
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup FactionId
fidUI ConnServerDict
oldD
in (Maybe ChanServer -> Maybe ChanServer)
-> FactionId -> ConnServerDict -> ConnServerDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ChanServer -> Maybe ChanServer
alt FactionId
fid (ConnServerDict -> ConnServerDict)
-> ConnServerDict -> ConnServerDict
forall a b. (a -> b) -> a -> b
$ FactionId -> ChanServer -> ConnServerDict -> ConnServerDict
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fidUI ChanServer
conn ConnServerDict
oldD
extraFacts :: FactionDict
extraFacts = (FactionId -> Faction -> Bool) -> FactionDict -> FactionDict
forall k a.
Enum k =>
(k -> a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filterWithKey (\FactionId
fid Faction
_ -> FactionId -> ConnServerDict -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
EM.notMember FactionId
fid ConnServerDict
swappedD)
FactionDict
factionD
ConnServerDict
extraD <- IO ConnServerDict -> m ConnServerDict
forall a. IO a -> m a
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
$ (Faction -> IO ChanServer) -> FactionDict -> IO ConnServerDict
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EnumMap FactionId a -> m (EnumMap FactionId b)
mapM Faction -> IO ChanServer
mkChanServer FactionDict
extraFacts
let exclusiveUnion :: EnumMap k a -> EnumMap k a -> EnumMap k a
exclusiveUnion = (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ((a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a)
-> (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"forbidden duplicate"
newD :: ConnServerDict
newD = ConnServerDict
swappedD ConnServerDict -> ConnServerDict -> ConnServerDict
forall {k} {a}. EnumMap k a -> EnumMap k a -> EnumMap k a
`exclusiveUnion` ConnServerDict
extraD
ConnServerDict -> m ()
forall (m :: * -> *). MonadServerComm m => ConnServerDict -> m ()
putDict ConnServerDict
newD
IO () -> m ()
forall a. IO a -> m a
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
extraD
tryRestore :: MonadServerComm m => m (Maybe (State, StateServer))
tryRestore :: forall (m :: * -> *).
MonadServerComm m =>
m (Maybe (State, StateServer))
tryRestore = do
COps{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
ServerOptions
soptions <- (StateServer -> ServerOptions) -> m ServerOptions
forall a. (StateServer -> a) -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (State, StateServer)
forall a. Maybe a
Nothing
else do
let prefix :: [Char]
prefix = ServerOptions -> [Char]
ssavePrefixSer ServerOptions
soptions
fileName :: [Char]
fileName = [Char]
prefix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> RuleContent -> [Char]
Save.saveNameSer RuleContent
corule
Maybe (State, StateServer)
res <- IO (Maybe (State, StateServer)) -> m (Maybe (State, StateServer))
forall a. IO a -> m a
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 -> [Char] -> IO (Maybe (State, StateServer))
forall a.
Binary a =>
RuleContent -> ClientOptions -> [Char] -> IO (Maybe a)
Save.restoreGame RuleContent
corule (ServerOptions -> ClientOptions
sclientOptions ServerOptions
soptions) [Char]
fileName
let cfgUIName :: [Char]
cfgUIName = RuleContent -> [Char]
rcfgUIName RuleContent
corule
(Text
configText, Config
_) = RuleContent -> (Text, Config)
rcfgUIDefault RuleContent
corule
[Char]
dataDir <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO IO [Char]
appDataDir
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
tryWriteFile ([Char]
dataDir [Char] -> [Char] -> [Char]
</> [Char]
cfgUIName) Text
configText
Maybe (State, StateServer) -> m (Maybe (State, StateServer))
forall a. a -> m a
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