module Game.LambdaHack.Server.MonadServer
(
MonadServer( getsServer
, modifyServer
, chanSaveServer
, liftIO
)
, MonadServerAtomic(..)
, getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit
, serverPrint, saveServer, dumpRngs, restoreScore, registerScore
, rndToAction, getSetGen
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Paths_LambdaHack as Self (version)
import qualified Control.Exception as Ex
import qualified Control.Monad.Trans.State.Strict as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import System.Exit (exitFailure)
import System.FilePath
import System.IO (hFlush, stdout)
import qualified System.Random as R
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.File
import qualified Game.LambdaHack.Common.HighScore as HighScore
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
class MonadStateRead m => MonadServer m where
getsServer :: (StateServer -> a) -> m a
modifyServer :: (StateServer -> StateServer) -> m ()
chanSaveServer :: m (Save.ChanSave (State, StateServer))
liftIO :: IO a -> m a
class MonadServer m => MonadServerAtomic m where
execUpdAtomic :: UpdAtomic -> m ()
execUpdAtomicSer :: UpdAtomic -> m Bool
execUpdAtomicFid :: FactionId -> UpdAtomic -> m ()
execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> m Bool
execSfxAtomic :: SfxAtomic -> m ()
execSendPer :: FactionId -> LevelId
-> Perception -> Perception -> Perception -> m ()
getServer :: MonadServer m => m StateServer
getServer = getsServer id
putServer :: MonadServer m => StateServer -> m ()
putServer s = modifyServer (const s)
debugPossiblyPrint :: MonadServer m => Text -> m ()
debugPossiblyPrint t = do
debug <- getsServer $ sdbgMsgSer . soptions
when debug $ liftIO $ do
T.hPutStrLn stdout t
hFlush stdout
debugPossiblyPrintAndExit :: MonadServer m => Text -> m ()
debugPossiblyPrintAndExit t = do
debug <- getsServer $ sdbgMsgSer . soptions
when debug $ liftIO $ do
T.hPutStrLn stdout t
hFlush stdout
exitFailure
serverPrint :: MonadServer m => Text -> m ()
serverPrint t = liftIO $ do
T.hPutStrLn stdout t
hFlush stdout
saveServer :: MonadServer m => m ()
saveServer = do
s <- getState
ser <- getServer
toSave <- chanSaveServer
liftIO $ Save.saveToChan toSave (s, ser)
dumpRngs :: MonadServer m => RNGs -> m ()
dumpRngs rngs = liftIO $ do
T.hPutStrLn stdout $ tshow rngs
hFlush stdout
restoreScore :: forall m. MonadServer m => COps -> m HighScore.ScoreDict
restoreScore cops = do
bench <- getsServer $ sbenchmark . sclientOptions . soptions
mscore <- if bench then return Nothing else do
let stdRuleset = getStdRuleset cops
scoresFile = rscoresFile stdRuleset
dataDir <- liftIO appDataDir
let path bkp = dataDir </> bkp <> scoresFile
configExists <- liftIO $ doesFileExist (path "")
res <- liftIO $ Ex.try $
if configExists then do
(vlib2, s) <- strictDecodeEOF (path "")
if vlib2 == Self.version
then return $ Just s
else do
let msg = "High score file from old version of game detected."
fail msg
else return Nothing
let handler :: Ex.SomeException -> m (Maybe a)
handler e = do
let msg = "High score restore failed. The old file moved aside. The error message is:"
<+> (T.unwords . T.lines) (tshow e)
serverPrint msg
liftIO $ renameFile (path "") (path "bkp.")
return Nothing
either handler return res
maybe (return HighScore.empty) return mscore
registerScore :: MonadServer m => Status -> FactionId -> m ()
registerScore status fid = do
cops <- getsState scops
total <- getsState $ snd . calculateTotal fid
let stdRuleset = getStdRuleset cops
scoresFile = rscoresFile stdRuleset
dataDir <- liftIO appDataDir
scoreDict <- restoreScore cops
gameModeId <- getsState sgameModeId
time <- getsState stime
dungeonTotal <- getsState sgold
date <- liftIO getPOSIXTime
tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date
curChalSer <- getsServer $ scurChalSer . soptions
factionD <- getsState sfactionD
bench <- getsServer $ sbenchmark . sclientOptions . soptions
noConfirmsGame <- isNoConfirmsGame
let fact = factionD EM.! fid
path = dataDir </> scoresFile
outputScore (worthMentioning, (ntable, pos)) =
if bench || noConfirmsGame || isAIFact fact then
debugPossiblyPrint $ T.intercalate "\n"
$ HighScore.showScore tz (pos, HighScore.getRecord pos ntable)
else
let nScoreDict = EM.insert gameModeId ntable scoreDict
in when worthMentioning $ liftIO $
encodeEOF path (Self.version, nScoreDict :: HighScore.ScoreDict)
chal | fhasUI $ gplayer fact = curChalSer
| otherwise = curChalSer
{cdiff = difficultyInverse (cdiff curChalSer)}
theirVic (fi, fa) | isFoe fid fact fi
&& not (isHorrorFact fa) = Just $ gvictims fa
| otherwise = Nothing
theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD
ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa
| otherwise = Nothing
ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD
table = HighScore.getTable gameModeId scoreDict
registeredScore =
HighScore.register table total dungeonTotal time status date chal
(T.unwords $ tail $ T.words $ gname fact)
ourVictims theirVictims
(fhiCondPoly $ gplayer fact)
outputScore registeredScore
rndToAction :: MonadServer m => Rnd a -> m a
rndToAction r = do
gen1 <- getsServer srandom
let (a, gen2) = St.runState r gen1
modifyServer $ \ser -> ser {srandom = gen2}
return a
getSetGen :: MonadServer m => Maybe R.StdGen -> m R.StdGen
getSetGen mrng = case mrng of
Just rnd -> return rnd
Nothing -> liftIO R.newStdGen