{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | The implementation of our custom game server monads. Just as any other
-- component of the library, this implementation can be substituted.
module Implementation.MonadServerImplementation
  ( executorSer
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , SerState(..), SerImplementation(..)
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import qualified Control.Exception as Ex
import qualified Control.Monad.IO.Class as IO
import           Control.Monad.Trans.State.Strict hiding (State)
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text.IO as T
import           Options.Applicative
  (defaultPrefs, execParserPure, handleParseResult)
import           System.Exit (ExitCode (ExitSuccess))
import           System.IO (hFlush, stdout)

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Client
import           Game.LambdaHack.Common.Kind
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.Server
import           Game.LambdaHack.Server.BroadcastAtomic
import           Game.LambdaHack.Server.HandleAtomicM
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.ProtocolM
import           Game.LambdaHack.Server.State

import Implementation.MonadClientImplementation (executorCli)

data SerState = SerState
  { SerState -> State
serState  :: State           -- ^ current global state
  , SerState -> StateServer
serServer :: StateServer     -- ^ current server state
  , SerState -> ConnServerDict
serDict   :: ConnServerDict  -- ^ client-server connection information
  , SerState -> ChanSave (State, StateServer)
serToSave :: Save.ChanSave (State, StateServer)
                                 -- ^ connection to the save thread
  }

-- | Server state transformation monad.
newtype SerImplementation a =
    SerImplementation {SerImplementation a -> StateT SerState IO a
runSerImplementation :: StateT SerState IO a}
  deriving (Applicative SerImplementation
a -> SerImplementation a
Applicative SerImplementation
-> (forall a b.
    SerImplementation a
    -> (a -> SerImplementation b) -> SerImplementation b)
-> (forall a b.
    SerImplementation a -> SerImplementation b -> SerImplementation b)
-> (forall a. a -> SerImplementation a)
-> Monad SerImplementation
SerImplementation a
-> (a -> SerImplementation b) -> SerImplementation b
SerImplementation a -> SerImplementation b -> SerImplementation b
forall a. a -> SerImplementation a
forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation b
forall a b.
SerImplementation a
-> (a -> SerImplementation b) -> SerImplementation b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SerImplementation a
$creturn :: forall a. a -> SerImplementation a
>> :: SerImplementation a -> SerImplementation b -> SerImplementation b
$c>> :: forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation b
>>= :: SerImplementation a
-> (a -> SerImplementation b) -> SerImplementation b
$c>>= :: forall a b.
SerImplementation a
-> (a -> SerImplementation b) -> SerImplementation b
$cp1Monad :: Applicative SerImplementation
Monad, a -> SerImplementation b -> SerImplementation a
(a -> b) -> SerImplementation a -> SerImplementation b
(forall a b.
 (a -> b) -> SerImplementation a -> SerImplementation b)
-> (forall a b. a -> SerImplementation b -> SerImplementation a)
-> Functor SerImplementation
forall a b. a -> SerImplementation b -> SerImplementation a
forall a b. (a -> b) -> SerImplementation a -> SerImplementation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SerImplementation b -> SerImplementation a
$c<$ :: forall a b. a -> SerImplementation b -> SerImplementation a
fmap :: (a -> b) -> SerImplementation a -> SerImplementation b
$cfmap :: forall a b. (a -> b) -> SerImplementation a -> SerImplementation b
Functor, Functor SerImplementation
a -> SerImplementation a
Functor SerImplementation
-> (forall a. a -> SerImplementation a)
-> (forall a b.
    SerImplementation (a -> b)
    -> SerImplementation a -> SerImplementation b)
-> (forall a b c.
    (a -> b -> c)
    -> SerImplementation a
    -> SerImplementation b
    -> SerImplementation c)
-> (forall a b.
    SerImplementation a -> SerImplementation b -> SerImplementation b)
-> (forall a b.
    SerImplementation a -> SerImplementation b -> SerImplementation a)
-> Applicative SerImplementation
SerImplementation a -> SerImplementation b -> SerImplementation b
SerImplementation a -> SerImplementation b -> SerImplementation a
SerImplementation (a -> b)
-> SerImplementation a -> SerImplementation b
(a -> b -> c)
-> SerImplementation a
-> SerImplementation b
-> SerImplementation c
forall a. a -> SerImplementation a
forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation a
forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation b
forall a b.
SerImplementation (a -> b)
-> SerImplementation a -> SerImplementation b
forall a b c.
(a -> b -> c)
-> SerImplementation a
-> SerImplementation b
-> SerImplementation c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SerImplementation a -> SerImplementation b -> SerImplementation a
$c<* :: forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation a
*> :: SerImplementation a -> SerImplementation b -> SerImplementation b
$c*> :: forall a b.
SerImplementation a -> SerImplementation b -> SerImplementation b
liftA2 :: (a -> b -> c)
-> SerImplementation a
-> SerImplementation b
-> SerImplementation c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> SerImplementation a
-> SerImplementation b
-> SerImplementation c
<*> :: SerImplementation (a -> b)
-> SerImplementation a -> SerImplementation b
$c<*> :: forall a b.
SerImplementation (a -> b)
-> SerImplementation a -> SerImplementation b
pure :: a -> SerImplementation a
$cpure :: forall a. a -> SerImplementation a
$cp1Applicative :: Functor SerImplementation
Applicative)

instance MonadStateRead SerImplementation where
  {-# INLINE getsState #-}
  getsState :: (State -> a) -> SerImplementation a
getsState State -> a
f = StateT SerState IO a -> SerImplementation a
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO a -> SerImplementation a)
-> StateT SerState IO a -> SerImplementation a
forall a b. (a -> b) -> a -> b
$ (SerState -> a) -> StateT SerState IO a
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((SerState -> a) -> StateT SerState IO a)
-> (SerState -> a) -> StateT SerState IO a
forall a b. (a -> b) -> a -> b
$ State -> a
f (State -> a) -> (SerState -> State) -> SerState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerState -> State
serState

instance MonadStateWrite SerImplementation where
  {-# INLINE modifyState #-}
  modifyState :: (State -> State) -> SerImplementation ()
modifyState State -> State
f = StateT SerState IO () -> SerImplementation ()
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO () -> SerImplementation ())
-> StateT SerState IO () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ (SerState -> ((), SerState)) -> StateT SerState IO ()
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((SerState -> ((), SerState)) -> StateT SerState IO ())
-> (SerState -> ((), SerState)) -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ \SerState
serS ->
    let !newSerS :: SerState
newSerS = SerState
serS {serState :: State
serState = State -> State
f (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ SerState -> State
serState SerState
serS}
    in ((), SerState
newSerS)
  {-# INLINE putState #-}
  putState :: State -> SerImplementation ()
putState State
newSerState = StateT SerState IO () -> SerImplementation ()
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO () -> SerImplementation ())
-> StateT SerState IO () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ (SerState -> ((), SerState)) -> StateT SerState IO ()
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((SerState -> ((), SerState)) -> StateT SerState IO ())
-> (SerState -> ((), SerState)) -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ \SerState
serS ->
    let !newSerS :: SerState
newSerS = SerState
serS {serState :: State
serState = State
newSerState}
    in ((), SerState
newSerS)

instance MonadServer SerImplementation where
  {-# INLINE getsServer #-}
  getsServer :: (StateServer -> a) -> SerImplementation a
getsServer   StateServer -> a
f = StateT SerState IO a -> SerImplementation a
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO a -> SerImplementation a)
-> StateT SerState IO a -> SerImplementation a
forall a b. (a -> b) -> a -> b
$ (SerState -> a) -> StateT SerState IO a
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((SerState -> a) -> StateT SerState IO a)
-> (SerState -> a) -> StateT SerState IO a
forall a b. (a -> b) -> a -> b
$ StateServer -> a
f (StateServer -> a) -> (SerState -> StateServer) -> SerState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerState -> StateServer
serServer
  {-# INLINE modifyServer #-}
  modifyServer :: (StateServer -> StateServer) -> SerImplementation ()
modifyServer StateServer -> StateServer
f = StateT SerState IO () -> SerImplementation ()
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO () -> SerImplementation ())
-> StateT SerState IO () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ (SerState -> ((), SerState)) -> StateT SerState IO ()
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((SerState -> ((), SerState)) -> StateT SerState IO ())
-> (SerState -> ((), SerState)) -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ \SerState
serS ->
    let !newSerS :: SerState
newSerS = SerState
serS {serServer :: StateServer
serServer = StateServer -> StateServer
f (StateServer -> StateServer) -> StateServer -> StateServer
forall a b. (a -> b) -> a -> b
$ SerState -> StateServer
serServer SerState
serS}
    in ((), SerState
newSerS)
  chanSaveServer :: SerImplementation (ChanSave (State, StateServer))
chanSaveServer = StateT SerState IO (ChanSave (State, StateServer))
-> SerImplementation (ChanSave (State, StateServer))
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO (ChanSave (State, StateServer))
 -> SerImplementation (ChanSave (State, StateServer)))
-> StateT SerState IO (ChanSave (State, StateServer))
-> SerImplementation (ChanSave (State, StateServer))
forall a b. (a -> b) -> a -> b
$ (SerState -> ChanSave (State, StateServer))
-> StateT SerState IO (ChanSave (State, StateServer))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets SerState -> ChanSave (State, StateServer)
serToSave
  liftIO :: IO a -> SerImplementation a
liftIO         = StateT SerState IO a -> SerImplementation a
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO a -> SerImplementation a)
-> (IO a -> StateT SerState IO a) -> IO a -> SerImplementation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> StateT SerState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO

instance MonadServerComm SerImplementation where
  {-# INLINE getsDict #-}
  getsDict :: (ConnServerDict -> a) -> SerImplementation a
getsDict   ConnServerDict -> a
f = StateT SerState IO a -> SerImplementation a
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO a -> SerImplementation a)
-> StateT SerState IO a -> SerImplementation a
forall a b. (a -> b) -> a -> b
$ (SerState -> a) -> StateT SerState IO a
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((SerState -> a) -> StateT SerState IO a)
-> (SerState -> a) -> StateT SerState IO a
forall a b. (a -> b) -> a -> b
$ ConnServerDict -> a
f (ConnServerDict -> a)
-> (SerState -> ConnServerDict) -> SerState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerState -> ConnServerDict
serDict
  {-# INLINE modifyDict #-}
  modifyDict :: (ConnServerDict -> ConnServerDict) -> SerImplementation ()
modifyDict ConnServerDict -> ConnServerDict
f = StateT SerState IO () -> SerImplementation ()
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO () -> SerImplementation ())
-> StateT SerState IO () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ (SerState -> ((), SerState)) -> StateT SerState IO ()
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((SerState -> ((), SerState)) -> StateT SerState IO ())
-> (SerState -> ((), SerState)) -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ \SerState
serS ->
    let !newSerS :: SerState
newSerS = SerState
serS {serDict :: ConnServerDict
serDict = ConnServerDict -> ConnServerDict
f (ConnServerDict -> ConnServerDict)
-> ConnServerDict -> ConnServerDict
forall a b. (a -> b) -> a -> b
$ SerState -> ConnServerDict
serDict SerState
serS}
    in ((), SerState
newSerS)
  liftIO :: IO a -> SerImplementation a
liftIO = StateT SerState IO a -> SerImplementation a
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO a -> SerImplementation a)
-> (IO a -> StateT SerState IO a) -> IO a -> SerImplementation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> StateT SerState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO

instance MonadServerAtomic SerImplementation where
  execUpdAtomic :: UpdAtomic -> SerImplementation ()
execUpdAtomic UpdAtomic
cmd = do
    State
oldState <- SerImplementation State
forall (m :: * -> *). MonadStateRead m => m State
getState
    (PosAtomic
ps, [UpdAtomic]
atomicBroken, Bool
executedOnServer) <- UpdAtomic -> SerImplementation (PosAtomic, [UpdAtomic], Bool)
forall (m :: * -> *).
MonadServerAtomic m =>
UpdAtomic -> m (PosAtomic, [UpdAtomic], Bool)
handleCmdAtomicServer UpdAtomic
cmd
    Bool -> SerImplementation () -> SerImplementation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
executedOnServer (SerImplementation () -> SerImplementation ())
-> SerImplementation () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ State -> UpdAtomic -> SerImplementation ()
forall (m :: * -> *). MonadServer m => State -> UpdAtomic -> m ()
cmdAtomicSemSer State
oldState UpdAtomic
cmd
    PosAtomic -> [UpdAtomic] -> CmdAtomic -> SerImplementation ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
PosAtomic -> [UpdAtomic] -> CmdAtomic -> m ()
handleAndBroadcast PosAtomic
ps [UpdAtomic]
atomicBroken (UpdAtomic -> CmdAtomic
UpdAtomic UpdAtomic
cmd)
  execUpdAtomicSer :: UpdAtomic -> SerImplementation Bool
execUpdAtomicSer UpdAtomic
cmd = StateT SerState IO Bool -> SerImplementation Bool
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO Bool -> SerImplementation Bool)
-> StateT SerState IO Bool -> SerImplementation Bool
forall a b. (a -> b) -> a -> b
$ (SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool)
-> (SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool
forall a b. (a -> b) -> a -> b
$ \SerState
cliS -> do
    Either AtomicFail SerState
cliSNewOrE <- IO SerState -> IO (Either AtomicFail SerState)
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try
                  (IO SerState -> IO (Either AtomicFail SerState))
-> IO SerState -> IO (Either AtomicFail SerState)
forall a b. (a -> b) -> a -> b
$ StateT SerState IO () -> SerState -> IO SerState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (SerImplementation () -> StateT SerState IO ()
forall a. SerImplementation a -> StateT SerState IO a
runSerImplementation (SerImplementation () -> StateT SerState IO ())
-> SerImplementation () -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> SerImplementation ()
forall (m :: * -> *). MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic UpdAtomic
cmd)
                               SerState
cliS
    case Either AtomicFail SerState
cliSNewOrE of
      Left AtomicFail{} -> (Bool, SerState) -> IO (Bool, SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, SerState
cliS)
      Right !SerState
cliSNew ->
        -- We know @cliSNew@ differs only in @serState@.
        (Bool, SerState) -> IO (Bool, SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, SerState
cliSNew)
  execUpdAtomicFid :: FactionId -> UpdAtomic -> SerImplementation ()
execUpdAtomicFid FactionId
fid UpdAtomic
cmd = StateT SerState IO () -> SerImplementation ()
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO () -> SerImplementation ())
-> StateT SerState IO () -> SerImplementation ()
forall a b. (a -> b) -> a -> b
$ (SerState -> IO ((), SerState)) -> StateT SerState IO ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((SerState -> IO ((), SerState)) -> StateT SerState IO ())
-> (SerState -> IO ((), SerState)) -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ \SerState
cliS -> do
    -- Don't catch anything; assume exceptions impossible.
    let sFid :: State
sFid = StateServer -> EnumMap FactionId State
sclientStates (SerState -> StateServer
serServer SerState
cliS) EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
    SerState
cliSNew <- StateT SerState IO () -> SerState -> IO SerState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (SerImplementation () -> StateT SerState IO ()
forall a. SerImplementation a -> StateT SerState IO a
runSerImplementation (SerImplementation () -> StateT SerState IO ())
-> SerImplementation () -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> SerImplementation ()
forall (m :: * -> *). MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic UpdAtomic
cmd)
                          SerState
cliS {serState :: State
serState = State
sFid}
    -- We know @cliSNew@ differs only in @serState@.
    let serServerNew :: StateServer
serServerNew = (SerState -> StateServer
serServer SerState
cliS)
          {sclientStates :: EnumMap FactionId State
sclientStates = FactionId
-> State -> EnumMap FactionId State -> EnumMap FactionId State
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fid (SerState -> State
serState SerState
cliSNew)
                           (EnumMap FactionId State -> EnumMap FactionId State)
-> EnumMap FactionId State -> EnumMap FactionId State
forall a b. (a -> b) -> a -> b
$ StateServer -> EnumMap FactionId State
sclientStates (StateServer -> EnumMap FactionId State)
-> StateServer -> EnumMap FactionId State
forall a b. (a -> b) -> a -> b
$ SerState -> StateServer
serServer SerState
cliS}
        !newCliS :: SerState
newCliS = SerState
cliS {serServer :: StateServer
serServer = StateServer
serServerNew}
    ((), SerState) -> IO ((), SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), SerState
newCliS)
  execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> SerImplementation Bool
execUpdAtomicFidCatch FactionId
fid UpdAtomic
cmd = StateT SerState IO Bool -> SerImplementation Bool
forall a. StateT SerState IO a -> SerImplementation a
SerImplementation (StateT SerState IO Bool -> SerImplementation Bool)
-> StateT SerState IO Bool -> SerImplementation Bool
forall a b. (a -> b) -> a -> b
$ (SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool)
-> (SerState -> IO (Bool, SerState)) -> StateT SerState IO Bool
forall a b. (a -> b) -> a -> b
$ \SerState
cliS -> do
    let sFid :: State
sFid = StateServer -> EnumMap FactionId State
sclientStates (SerState -> StateServer
serServer SerState
cliS) EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
    Either AtomicFail SerState
cliSNewOrE <- IO SerState -> IO (Either AtomicFail SerState)
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try
                  (IO SerState -> IO (Either AtomicFail SerState))
-> IO SerState -> IO (Either AtomicFail SerState)
forall a b. (a -> b) -> a -> b
$ StateT SerState IO () -> SerState -> IO SerState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (SerImplementation () -> StateT SerState IO ()
forall a. SerImplementation a -> StateT SerState IO a
runSerImplementation (SerImplementation () -> StateT SerState IO ())
-> SerImplementation () -> StateT SerState IO ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> SerImplementation ()
forall (m :: * -> *). MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic UpdAtomic
cmd)
                               SerState
cliS {serState :: State
serState = State
sFid}
    case Either AtomicFail SerState
cliSNewOrE of
      Left AtomicFail{} -> (Bool, SerState) -> IO (Bool, SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, SerState
cliS)
      Right SerState
cliSNew -> do
        -- We know @cliSNew@ differs only in @serState@.
        let serServerNew :: StateServer
serServerNew = (SerState -> StateServer
serServer SerState
cliS)
              {sclientStates :: EnumMap FactionId State
sclientStates = FactionId
-> State -> EnumMap FactionId State -> EnumMap FactionId State
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fid (SerState -> State
serState SerState
cliSNew)
                               (EnumMap FactionId State -> EnumMap FactionId State)
-> EnumMap FactionId State -> EnumMap FactionId State
forall a b. (a -> b) -> a -> b
$ StateServer -> EnumMap FactionId State
sclientStates (StateServer -> EnumMap FactionId State)
-> StateServer -> EnumMap FactionId State
forall a b. (a -> b) -> a -> b
$ SerState -> StateServer
serServer SerState
cliS}
            !newCliS :: SerState
newCliS = SerState
cliS {serServer :: StateServer
serServer = StateServer
serServerNew}
        (Bool, SerState) -> IO (Bool, SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, SerState
newCliS)
  execSfxAtomic :: SfxAtomic -> SerImplementation ()
execSfxAtomic SfxAtomic
sfx = do
    PosAtomic
ps <- SfxAtomic -> SerImplementation PosAtomic
forall (m :: * -> *). MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic SfxAtomic
sfx
    PosAtomic -> [UpdAtomic] -> CmdAtomic -> SerImplementation ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
PosAtomic -> [UpdAtomic] -> CmdAtomic -> m ()
handleAndBroadcast PosAtomic
ps [] (SfxAtomic -> CmdAtomic
SfxAtomic SfxAtomic
sfx)
  execSendPer :: FactionId
-> LevelId
-> Perception
-> Perception
-> Perception
-> SerImplementation ()
execSendPer = FactionId
-> LevelId
-> Perception
-> Perception
-> Perception
-> SerImplementation ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
FactionId
-> LevelId -> Perception -> Perception -> Perception -> m ()
sendPer

-- Don't inline this, to keep GHC hard work inside the library
-- for easy access of code analysis tools.
-- | Run the main server loop, with the given arguments and empty
-- initial states, in the @IO@ monad.
executorSer :: COps -> CCUI -> ServerOptions -> UIOptions -> IO ()
executorSer :: COps -> CCUI -> ServerOptions -> UIOptions -> IO ()
executorSer cops :: COps
cops@COps{RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} CCUI
ccui ServerOptions
soptionsNxtCmdline UIOptions
sUIOptions = do
  ServerOptions
soptionsNxtRaw <- case UIOptions -> [String]
uOverrideCmdline UIOptions
sUIOptions of
    []   -> ServerOptions -> IO ServerOptions
forall (m :: * -> *) a. Monad m => a -> m a
return ServerOptions
soptionsNxtCmdline
    [String]
args -> ParserResult ServerOptions -> IO ServerOptions
forall a. ParserResult a -> IO a
handleParseResult (ParserResult ServerOptions -> IO ServerOptions)
-> ParserResult ServerOptions -> IO ServerOptions
forall a b. (a -> b) -> a -> b
$ ParserPrefs
-> ParserInfo ServerOptions
-> [String]
-> ParserResult ServerOptions
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs ParserInfo ServerOptions
serverOptionsPI [String]
args
  -- Options for the clients modified with the configuration file.
  let clientOptions :: ClientOptions
clientOptions = COps -> UIOptions -> ClientOptions -> ClientOptions
applyUIOptions COps
cops UIOptions
sUIOptions
                      (ClientOptions -> ClientOptions) -> ClientOptions -> ClientOptions
forall a b. (a -> b) -> a -> b
$ ServerOptions -> ClientOptions
sclientOptions ServerOptions
soptionsNxtRaw
      soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
soptionsNxtRaw {sclientOptions :: ClientOptions
sclientOptions = ClientOptions
clientOptions}
      -- Partially applied main loop of the clients.
      executorClient :: Bool -> FactionId -> ChanServer -> IO ()
executorClient = CCUI
-> UIOptions
-> ClientOptions
-> COps
-> Bool
-> FactionId
-> ChanServer
-> IO ()
executorCli CCUI
ccui UIOptions
sUIOptions ClientOptions
clientOptions COps
cops
  -- Wire together game content, the main loop of game clients
  -- and the game server loop.
  let stateToFileName :: (State, StateServer) -> String
stateToFileName (State
_, StateServer
ser) =
        ServerOptions -> String
ssavePrefixSer (StateServer -> ServerOptions
soptions StateServer
ser) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RuleContent -> String
Save.saveNameSer RuleContent
corule
      totalState :: ChanSave (State, StateServer) -> SerState
totalState ChanSave (State, StateServer)
serToSave = SerState :: State
-> StateServer
-> ConnServerDict
-> ChanSave (State, StateServer)
-> SerState
SerState
        { serState :: State
serState = (COps -> COps) -> State -> State
updateCOpsAndCachedData (COps -> COps -> COps
forall a b. a -> b -> a
const COps
cops) State
emptyState
            -- state is empty, so the cached data is left empty and untouched
        , serServer :: StateServer
serServer = StateServer
emptyStateServer
        , serDict :: ConnServerDict
serDict = ConnServerDict
forall k a. EnumMap k a
EM.empty
        , ChanSave (State, StateServer)
serToSave :: ChanSave (State, StateServer)
serToSave :: ChanSave (State, StateServer)
serToSave
        }
      m :: SerImplementation ()
m = ServerOptions
-> (Bool -> FactionId -> ChanServer -> IO ())
-> SerImplementation ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
ServerOptions -> (Bool -> FactionId -> ChanServer -> IO ()) -> m ()
loopSer ServerOptions
soptionsNxt Bool -> FactionId -> ChanServer -> IO ()
executorClient
      exe :: ChanSave (State, StateServer) -> IO ()
exe = StateT SerState IO () -> SerState -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SerImplementation () -> StateT SerState IO ()
forall a. SerImplementation a -> StateT SerState IO a
runSerImplementation SerImplementation ()
m) (SerState -> IO ())
-> (ChanSave (State, StateServer) -> SerState)
-> ChanSave (State, StateServer)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChanSave (State, StateServer) -> SerState
totalState
      exeWithSaves :: IO ()
exeWithSaves = COps
-> ((State, StateServer) -> String)
-> (ChanSave (State, StateServer) -> IO ())
-> IO ()
forall a.
Binary a =>
COps -> (a -> String) -> (ChanSave a -> IO ()) -> IO ()
Save.wrapInSaves COps
cops (State, StateServer) -> String
stateToFileName ChanSave (State, StateServer) -> IO ()
exe
  -- Wait for clients to exit even in case of server crash
  -- (or server and client crash), which gives them time to save
  -- and report their own inconsistencies, if any.
  (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Ex.handle (\SomeException
ex -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
ex of
               Just ExitCode
ExitSuccess ->
                 -- User-forced shutdown, not crash, so the intention is
                 -- to keep old saves and also clients may be not ready to save.
                 SomeException -> IO ()
forall e a. Exception e => e -> IO a
Ex.throwIO SomeException
ex
               Maybe ExitCode
_ -> do
                 IO () -> IO ()
forall a. IO a -> IO a
Ex.uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
                   -- let clients report their errors and save
                 Bool
moveAside <- RuleContent -> ClientOptions -> IO Bool
Save.bkpAllSaves RuleContent
corule ClientOptions
clientOptions
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
moveAside (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                   Handle -> Text -> IO ()
T.hPutStrLn Handle
stdout
                               Text
"The game crashed, so savefiles are moved aside."
                 Handle -> IO ()
hFlush Handle
stdout
                 SomeException -> IO ()
forall e a. Exception e => e -> IO a
Ex.throwIO SomeException
ex  -- crash eventually, which kills clients
            )
            IO ()
exeWithSaves
--  T.hPutStrLn stdout "Server exiting, waiting for clients."
--  hFlush stdout
  MVar [Async ()] -> IO ()
waitForChildren MVar [Async ()]
childrenServer  -- no crash, wait for clients indefinitely
--  T.hPutStrLn stdout "Server exiting now."
--  hFlush stdout