{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game.LambdaHack.SampleImplementation.SampleMonadServer
( executorSer
#ifdef EXPOSE_INTERNAL
, SerState(..), SerImplementation(..)
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.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 System.FilePath
import System.IO (hFlush, stdout)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Client.UI.Config
import Game.LambdaHack.Client.UI.Content.KeyKind
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.File
import qualified Game.LambdaHack.Common.Kind as 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.SampleImplementation.SampleMonadClient (executorCli)
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
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 !newSerState = f $ serState serS
in ((), serS {serState = newSerState})
instance MonadServer SerImplementation where
{-# INLINE getsServer #-}
getsServer f = SerImplementation $ gets $ f . serServer
{-# INLINE modifyServer #-}
modifyServer f = SerImplementation $ state $ \serS ->
let !newSerServer = f $ serServer serS
in ((), serS {serServer = newSerServer})
saveChanServer = SerImplementation $ gets serToSave
liftIO = SerImplementation . IO.liftIO
instance MonadServerReadRequest SerImplementation where
{-# INLINE getsDict #-}
getsDict f = SerImplementation $ gets $ f . serDict
{-# INLINE modifyDict #-}
modifyDict f = SerImplementation $ state $ \serS ->
let !newSerDict = f $ serDict serS
in ((), serS {serDict = newSerDict})
liftIO = SerImplementation . IO.liftIO
instance MonadAtomic SerImplementation where
execUpdAtomic cmd = cmdAtomicSemSer cmd >> handleAndBroadcast (UpdAtomic cmd)
execSfxAtomic sfx = handleAndBroadcast (SfxAtomic sfx)
execSendPer = sendPer
executorSer :: Kind.COps -> KeyKind -> DebugModeSer -> IO ()
executorSer cops copsClient sdebugNxtCmdline = do
sconfig <- mkConfig cops (sbenchmark $ sdebugCli sdebugNxtCmdline)
sdebugNxt <- case configCmdline sconfig of
[] -> return sdebugNxtCmdline
args -> return $! debugArgs args
let sdebugMode = applyConfigToDebug cops sconfig $ sdebugCli sdebugNxt
executorClient = executorCli (loopCli copsClient sconfig sdebugMode)
let m = loopSer sdebugNxt sconfig executorClient
stateToFileName (_, ser) =
ssavePrefixSer (sdebugSer ser) <.> Save.saveNameSer
totalState serToSave = SerState
{ serState = emptyState cops
, serServer = emptyStateServer
, serDict = EM.empty
, serToSave
}
exe = evalStateT (runSerImplementation m) . totalState
exeWithSaves = Save.wrapInSaves cops stateToFileName exe
defPrefix = ssavePrefixSer defDebugModeSer
bkpOneSave name = do
dataDir <- appDataDir
let path bkp = dataDir </> "saves" </> bkp <> name
b <- doesFileExist (path "")
when b $ renameFile (path "") (path "bkp.")
bkpAllSaves = do
T.hPutStrLn stdout "The game crashed, so savefiles are moved aside."
bkpOneSave $ defPrefix <.> Save.saveNameSer
forM_ [-99..99] $ \n ->
bkpOneSave $ defPrefix <.> Save.saveNameCli (toEnum n)
Ex.handle (\(ex :: Ex.SomeException) -> do
Ex.uninterruptibleMask_ $ threadDelay 1000000
when (ssavePrefixSer sdebugNxt == defPrefix) bkpAllSaves
hFlush stdout
Ex.throw ex)
exeWithSaves
waitForChildren childrenServer