-- | The server definitions for the server-client communication protocol.
module Game.LambdaHack.Server.ProtocolM
  ( -- * The communication channels
    CliSerQueue, ConnServerDict, ChanServer(..)
    -- * The server-client communication monad
  , MonadServerComm
      ( getsDict  -- exposed only to be implemented, not used
      , modifyDict  -- exposed only to be implemented, not used
      , liftIO  -- exposed only to be implemented, not used
      )
    -- * Protocol
  , putDict, sendUpdate, sendUpdateCheck, sendUpdNoState
  , sendSfx, sendQueryAI, sendQueryUI
    -- * Assorted
  , killAllClients, childrenServer, updateConn, tryRestore
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , 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

-- | Connection information for all factions, indexed by faction identifier.
type ConnServerDict = EM.EnumMap FactionId ChanServer

-- | Connection channel between the server and a single client.
data ChanServer = ChanServer
  { ChanServer -> CliSerQueue Response
responseS  :: CliSerQueue Response
  , ChanServer -> CliSerQueue RequestAI
requestAIS :: CliSerQueue RequestAI
  , ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS :: Maybe (CliSerQueue RequestUI)
  }

-- | The server monad with the ability to communicate with clients.
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)

-- | If the @AtomicFail@ conditions hold, send a command to client,
-- otherwise do nothing.
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

-- | Send a command to client, crashing if the @AtomicFail@ conditions
-- don't hold when executed on the client's state.
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
  -- We can't interate over sfactionD, because client can be from an old game.
  -- For the same reason we can't look up and send client's state.
  (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

-- Global variable for all children threads of the server.
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 [])

-- | Update connections to the new definition of factions.
-- Connect to clients in old or newly spawned threads
-- that read and write directly to the channels.
updateConn :: (MonadServerAtomic m, MonadServerComm m)
           => (Bool -> FactionId -> ChanServer -> IO ())
           -> m ()
updateConn :: (Bool -> FactionId -> ChanServer -> IO ()) -> m ()
updateConn Bool -> FactionId -> ChanServer -> IO ()
executorClient = do
  -- Prepare connections based on factions.
  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  -- share old conns and threads
        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  -- re-use session to keep history
  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  -- never kill old clients
  ConnServerDict -> m ()
forall (m :: * -> *). MonadServerComm m => ConnServerDict -> m ()
putDict ConnServerDict
newD
  -- Spawn client threads.
  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} =
        -- When a connection is reused, clients are not respawned,
        -- even if UI status of a faction changes, but it works OK thanks to
        -- UI faction clients distinguished by positive FactionId numbers.
        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