{-# 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.FilePath
import System.IO (hFlush, stdout)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
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.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.ServerOptions
import Game.LambdaHack.Server.State
import Implementation.MonadClientImplementation (executorCli)
data SerState = SerState
{ serState :: State
, serServer :: StateServer
, serDict :: ConnServerDict
, serToSave :: Save.ChanSave (State, StateServer)
}
newtype SerImplementation a =
SerImplementation {runSerImplementation :: StateT SerState IO a}
deriving (Monad, Functor, Applicative)
instance MonadStateRead SerImplementation where
{-# INLINE getsState #-}
getsState f = SerImplementation $ gets $ f . serState
instance MonadStateWrite SerImplementation where
{-# INLINE modifyState #-}
modifyState f = SerImplementation $ state $ \serS ->
let !newSerS = serS {serState = f $ serState serS}
in ((), newSerS)
{-# INLINE putState #-}
putState newSerState = SerImplementation $ state $ \serS ->
let !newSerS = serS {serState = newSerState}
in ((), newSerS)
instance MonadServer SerImplementation where
{-# INLINE getsServer #-}
getsServer f = SerImplementation $ gets $ f . serServer
{-# INLINE modifyServer #-}
modifyServer f = SerImplementation $ state $ \serS ->
let !newSerS = serS {serServer = f $ serServer serS}
in ((), newSerS)
chanSaveServer = SerImplementation $ gets serToSave
liftIO = SerImplementation . IO.liftIO
instance MonadServerComm SerImplementation where
{-# INLINE getsDict #-}
getsDict f = SerImplementation $ gets $ f . serDict
{-# INLINE modifyDict #-}
modifyDict f = SerImplementation $ state $ \serS ->
let !newSerS = serS {serDict = f $ serDict serS}
in ((), newSerS)
liftIO = SerImplementation . IO.liftIO
instance MonadServerAtomic SerImplementation where
execUpdAtomic cmd = do
oldState <- getState
(ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd
when executedOnServer $ cmdAtomicSemSer oldState cmd
handleAndBroadcast ps atomicBroken (UpdAtomic cmd)
execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do
cliSNewOrE <- Ex.try
$ execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS
case cliSNewOrE of
Left AtomicFail{} -> return (False, cliS)
Right !cliSNew ->
return (True, cliSNew)
execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do
let sFid = sclientStates (serServer cliS) EM.! fid
cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS {serState = sFid}
let serServerNew = (serServer cliS)
{sclientStates = EM.insert fid (serState cliSNew)
$ sclientStates $ serServer cliS}
!newCliS = cliS {serServer = serServerNew}
return ((), newCliS)
execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do
let sFid = sclientStates (serServer cliS) EM.! fid
cliSNewOrE <- Ex.try
$ execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS {serState = sFid}
case cliSNewOrE of
Left AtomicFail{} -> return (False, cliS)
Right cliSNew -> do
let serServerNew = (serServer cliS)
{sclientStates = EM.insert fid (serState cliSNew)
$ sclientStates $ serServer cliS}
!newCliS = cliS {serServer = serServerNew}
return (True, newCliS)
execSfxAtomic sfx = do
ps <- posSfxAtomic sfx
handleAndBroadcast ps [] (SfxAtomic sfx)
execSendPer = sendPer
executorSer :: COps -> CCUI -> ServerOptions -> UIOptions -> IO ()
executorSer cops ccui soptionsNxtCmdline sUIOptions = do
soptionsNxtRaw <- case uCmdline sUIOptions of
[] -> return soptionsNxtCmdline
args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args
let clientOptions = applyUIOptions cops sUIOptions
$ sclientOptions soptionsNxtRaw
soptionsNxt = soptionsNxtRaw {sclientOptions = clientOptions}
executorClient = executorCli ccui sUIOptions clientOptions cops
let stateToFileName (_, ser) =
ssavePrefixSer (soptions ser) <> Save.saveNameSer cops
totalState serToSave = SerState
{ serState = updateCOpsAndCachedData (const cops) emptyState
, serServer = emptyStateServer
, serDict = EM.empty
, serToSave
}
m = loopSer soptionsNxt executorClient
exe = evalStateT (runSerImplementation m) . totalState
exeWithSaves = Save.wrapInSaves cops stateToFileName exe
defPrefix = ssavePrefixSer defServerOptions
bkpOneSave name = do
dataDir <- appDataDir
let path bkp = dataDir </> "saves" </> bkp <> name
b <- doesFileExist (path "")
when b $ renameFile (path "") (path "bkp.")
bkpAllSaves = unless (sbenchmark $ sclientOptions soptionsNxt) $ do
T.hPutStrLn stdout "The game crashed, so savefiles are moved aside."
bkpOneSave $ defPrefix <> Save.saveNameSer cops
forM_ [-99..99] $ \n ->
bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n)
Ex.handle (\ex -> case Ex.fromException ex of
Just ExitSuccess ->
Ex.throwIO ex
_ -> do
Ex.uninterruptibleMask_ $ threadDelay 1000000
when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves
hFlush stdout
Ex.throwIO ex
)
exeWithSaves
waitForChildren childrenServer