-- | 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
      , putDict  -- exposed only to be implemented, not used
      , liftIO  -- exposed only to be implemented, not used
      )
    -- * Protocol
  , 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_)
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

-- | 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
  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

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

-- | 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 :: 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
  -- 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 ()
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)
           => (FactionId -> ChanServer -> IO ())
           -> m ()
updateConn :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
(FactionId -> ChanServer -> IO ()) -> m ()
updateConn 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 (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
    -- Easy case, nothing to recycle, frontend not spawned yet.
    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
    -- Hard case, but we know there is exactly one UI connection in oldD,
    -- so we can reuse it for any new UI faction (to keep history).
    -- UI session (history in particular) is preserved even over game
    -- save and reload. It gets saved with the savefile of the team
    -- that is a UI faction and restored intact. However, when a new game
    -- is started from commandline (@--newGame@), even if it's using the same
    -- save prefix (@--savePrefix@), the session data is often lost.
    -- AI factions don't care which client they use, so we don't always
    -- preserve the old assignments either of factions or teams.
    let -- Find the new UI faction.
        (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
        -- Swap UI and AI connections around.
        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  -- UI connection at the same place; nothing to do
            else let -- Move the AI connection that was at new UI faction spot,
                     -- to the freed old UI spot.
                     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
        -- Add extra AI connections.
        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
    -- Spawn the extra AI client threads.
    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