{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Implementation.MonadServerImplementation
( executorSer
#ifdef EXPOSE_INTERNAL
, 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
, SerState -> StateServer
serServer :: StateServer
, SerState -> ConnServerDict
serDict :: ConnServerDict
, SerState -> ChanSave (State, StateServer)
serToSave :: Save.ChanSave (State, StateServer)
}
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 f :: 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 f :: 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
$ \serS :: 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 newSerState :: 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
$ \serS :: 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 f :: 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 f :: 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
$ \serS :: 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 f :: 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 f :: 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
$ \serS :: 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 cmd :: UpdAtomic
cmd = do
State
oldState <- SerImplementation State
forall (m :: * -> *). MonadStateRead m => m State
getState
(ps :: PosAtomic
ps, atomicBroken :: [UpdAtomic]
atomicBroken, executedOnServer :: 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 cmd :: 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
$ \cliS :: 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 ->
(Bool, SerState) -> IO (Bool, SerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, SerState
cliSNew)
execUpdAtomicFid :: FactionId -> UpdAtomic -> SerImplementation ()
execUpdAtomicFid fid :: FactionId
fid cmd :: 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
$ \cliS :: 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
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}
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 fid :: FactionId
fid cmd :: 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
$ \cliS :: 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 cliSNew :: SerState
cliSNew -> do
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 sfx :: 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
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
ccui soptionsNxtCmdline :: ServerOptions
soptionsNxtCmdline sUIOptions :: UIOptions
sUIOptions = do
ServerOptions
soptionsNxtRaw <- case UIOptions -> [String]
uCmdline UIOptions
sUIOptions of
[] -> ServerOptions -> IO ServerOptions
forall (m :: * -> *) a. Monad m => a -> m a
return ServerOptions
soptionsNxtCmdline
args :: [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
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}
executorClient :: Bool -> FactionId -> ChanServer -> IO ()
executorClient = CCUI
-> UIOptions
-> ClientOptions
-> COps
-> Bool
-> FactionId
-> ChanServer
-> IO ()
executorCli CCUI
ccui UIOptions
sUIOptions ClientOptions
clientOptions COps
cops
let stateToFileName :: (State, StateServer) -> String
stateToFileName (_, ser :: 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 serToSave :: ChanSave (State, StateServer)
serToSave = $WSerState :: 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
, 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
(SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Ex.handle (\ex :: SomeException
ex -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
ex of
Just ExitSuccess ->
SomeException -> IO ()
forall e a. Exception e => e -> IO a
Ex.throwIO SomeException
ex
_ -> 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 1000000
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
"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
)
IO ()
exeWithSaves
MVar [Async ()] -> IO ()
waitForChildren MVar [Async ()]
childrenServer