{-# 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 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 ->
(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
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 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
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
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
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 (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
, 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 (\SomeException
ex -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
ex of
Just ExitCode
ExitSuccess ->
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
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
)
IO ()
exeWithSaves
MVar [Async ()] -> IO ()
waitForChildren MVar [Async ()]
childrenServer