module Game.LambdaHack.Server.Action
(
MonadServer( getServer, getsServer, putServer, modifyServer, saveServer )
, MonadConnServer
, tryRestore, updateConn, killAllClients, speedupCOps
, sendUpdateAI, sendQueryAI, sendPingAI
, sendUpdateUI, sendQueryUI, sendPingUI
, debugPrint, dumpCfg
, mkConfigRules, restoreScore, revealItems, deduceQuits
, rndToAction, resetSessionStart, elapsedSessionTimeGT
, resetFidPerception, getPerFid
, childrenServer
) where
import Control.Concurrent
import Control.Concurrent.STM (TQueue, atomically)
import qualified Control.Concurrent.STM as STM
import Control.DeepSeq
import Control.Monad
import qualified Control.Monad.State as St
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM, mapWithKeyM_)
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Game.LambdaHack.Utils.Thread
import System.Directory
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random as R
import System.Time
import Control.Exception.Assert.Sugar
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.ClientCmd
import qualified Game.LambdaHack.Common.ConfigIO as ConfigIO
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.HighScore as HighScore
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Frontend as Frontend
import Game.LambdaHack.Server.Action.ActionClass
import Game.LambdaHack.Server.Config
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.State
import Game.LambdaHack.Utils.File
debugPrint :: MonadServer m => Text -> m ()
debugPrint t = do
debug <- getsServer $ sdbgMsgSer . sdebugSer
when debug $ liftIO $ do
T.hPutStrLn stderr t
hFlush stderr
resetFidPerception :: MonadServer m => FactionId -> LevelId -> m ()
resetFidPerception fid lid = do
cops <- getsState scops
lvl <- getLevel lid
fovMode <- getsServer $ sfovMode . sdebugSer
s <- getState
let per = levelPerception cops s (fromMaybe (Digital 12) fovMode) fid lid lvl
upd = EM.adjust (EM.adjust (const per) lid) fid
modifyServer $ \ser -> ser {sper = upd (sper ser)}
getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception
getPerFid fid lid = do
pers <- getsServer sper
let fper = fromMaybe (assert `failure` "no perception for faction"
`twith` (lid, fid)) $ EM.lookup fid pers
per = fromMaybe (assert `failure` "no perception for level"
`twith` (lid, fid)) $ EM.lookup lid fper
return $! per
dumpCfg :: MonadServer m => m String
dumpCfg = do
Config{configAppDataDir, configRulesCfgFile} <- getsServer sconfig
let fn = configAppDataDir </> configRulesCfgFile ++ ".dump"
config <- getsServer sconfig
liftIO $ ConfigIO.dump config fn
return fn
writeTQueueAI :: MonadConnServer m => CmdClientAI -> TQueue CmdClientAI -> m ()
writeTQueueAI cmd fromServer = do
debug <- getsServer $ sniffOut . sdebugSer
when debug $ do
d <- debugCmdClientAI cmd
liftIO $ T.hPutStrLn stderr d
liftIO $ atomically $ STM.writeTQueue fromServer cmd
writeTQueueUI :: MonadConnServer m => CmdClientUI -> TQueue CmdClientUI -> m ()
writeTQueueUI cmd fromServer = do
debug <- getsServer $ sniffOut . sdebugSer
when debug $ do
d <- debugCmdClientUI cmd
liftIO $ T.hPutStrLn stderr d
liftIO $ atomically $ STM.writeTQueue fromServer cmd
readTQueueAI :: MonadConnServer m => TQueue CmdSerTakeTime -> m CmdSerTakeTime
readTQueueAI toServer = do
cmd <- liftIO $ atomically $ STM.readTQueue toServer
debug <- getsServer $ sniffIn . sdebugSer
when debug $ do
let aid = aidCmdSerTakeTime cmd
d <- debugAid aid "CmdSerTakeTime" cmd
liftIO $ T.hPutStrLn stderr d
return cmd
readTQueueUI :: MonadConnServer m => TQueue CmdSer -> m CmdSer
readTQueueUI toServer = do
cmd <- liftIO $ atomically $ STM.readTQueue toServer
debug <- getsServer $ sniffIn . sdebugSer
when debug $ do
let aid = aidCmdSer cmd
d <- debugAid aid "CmdSer" cmd
liftIO $ T.hPutStrLn stderr d
return cmd
sendUpdateAI :: MonadConnServer m => FactionId -> CmdClientAI -> m ()
sendUpdateAI fid cmd = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI cmd $ fromServer conn
sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdSerTakeTime
sendQueryAI fid aid = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI (CmdQueryAI aid) $ fromServer conn
readTQueueAI $ toServer conn
sendPingAI :: MonadConnServer m => FactionId -> m ()
sendPingAI fid = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI CmdPingAI $ fromServer conn
cmdHack <- readTQueueAI $ toServer conn
assert (cmdHack == WaitSer (toEnum (1))) skip
sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m ()
sendUpdateUI fid cmd = do
cs <- getsDict $ fst . (EM.! fid)
case cs of
Nothing -> assert `failure` "no channel for faction" `twith` fid
Just (_, conn) ->
writeTQueueUI cmd $ fromServer conn
sendQueryUI :: MonadConnServer m => FactionId -> ActorId -> m CmdSer
sendQueryUI fid aid = do
cs <- getsDict $ fst . (EM.! fid)
case cs of
Nothing -> assert `failure` "no channel for faction" `twith` fid
Just (_, conn) -> do
writeTQueueUI (CmdQueryUI aid) $ fromServer conn
readTQueueUI $ toServer conn
sendPingUI :: MonadConnServer m => FactionId -> m ()
sendPingUI fid = do
cs <- getsDict $ fst . (EM.! fid)
case cs of
Nothing -> assert `failure` "no channel for faction" `twith` fid
Just (_, conn) -> do
writeTQueueUI CmdPingUI $ fromServer conn
cmdHack <- readTQueueUI $ toServer conn
assert (cmdHack == TakeTimeSer (WaitSer (toEnum (1)))) skip
restoreScore :: MonadServer m => Config -> m HighScore.ScoreTable
restoreScore Config{configAppDataDir, configScoresFile} = do
let path = configAppDataDir </> configScoresFile
configExists <- liftIO $ doesFileExist path
if not configExists
then return HighScore.empty
else liftIO $ strictDecodeEOF path
registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()
registerScore status mbody fid = do
assert (maybe True ((fid ==) . bfid) mbody) skip
factionD <- getsState sfactionD
let fact = factionD EM.! fid
assert (playerHuman $ gplayer fact) skip
total <- case mbody of
Just body -> getsState $ snd . calculateTotal body
Nothing -> case gleader fact of
Nothing -> return 0
Just aid -> do
b <- getsState $ getActorBody aid
getsState $ snd . calculateTotal b
config@Config{configAppDataDir, configScoresFile} <- getsServer sconfig
table <- restoreScore config
time <- getsState stime
date <- liftIO getClockTime
let path = configAppDataDir </> configScoresFile
saveScore (ntable, _) =
liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)
maybe skip saveScore $ HighScore.register table total time status date
resetSessionStart :: MonadServer m => m ()
resetSessionStart = do
sstart <- liftIO getClockTime
modifyServer $ \ser -> ser {sstart}
elapsedSessionTimeGT :: MonadServer m => Int -> m Bool
elapsedSessionTimeGT stopAfter = do
current <- liftIO getClockTime
TOD s p <- getsServer sstart
return $ TOD (s + fromIntegral stopAfter) p <= current
revealItems :: (MonadAtomic m, MonadServer m)
=> Maybe FactionId -> Maybe Actor -> m ()
revealItems mfid mbody = do
dungeon <- getsState sdungeon
discoS <- getsServer sdisco
let discover b iid _numPieces = do
item <- getsState $ getItemBody iid
let ik = fromJust $ jkind discoS item
execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik
f aid = do
b <- getsState $ getActorBody aid
let ourSide = maybe True (== bfid b) mfid
when (ourSide && Just b /= mbody) $ mapActorItems_ (discover b) b
mapDungeonActors_ f dungeon
maybe skip (\b -> mapActorItems_ (discover b) b) mbody
quitF :: (MonadAtomic m, MonadServer m)
=> Maybe Actor -> Status -> FactionId -> m ()
quitF mbody status fid = do
assert (maybe True ((fid ==) . bfid) mbody) skip
fact <- getsState $ (EM.! fid) . sfactionD
let oldSt = gquit fact
case fmap stOutcome $ oldSt of
Just Killed -> return ()
Just Defeated -> return ()
Just Conquer -> return ()
Just Escape -> return ()
_ -> do
when (playerUI $ gplayer fact) $ do
revealItems (Just fid) mbody
when (playerHuman $ gplayer fact) $ do
registerScore status mbody fid
execCmdAtomic $ QuitFactionA fid mbody oldSt $ Just status
modifyServer $ \ser -> ser {squit = True}
deduceQuits :: (MonadAtomic m, MonadServer m) => Actor -> Status -> m ()
deduceQuits body status@Status{stOutcome}
| stOutcome `elem` [Defeated, Camping, Restart, Conquer] =
assert `failure` "no quitting to deduce" `twith` (status, body)
deduceQuits body status = do
cops <- getsState scops
let fid = bfid body
mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids
quitF (Just body) status fid
let inGame fact = case fmap stOutcome $ gquit fact of
Just Killed -> False
Just Defeated -> False
Just Restart -> False
_ -> True
factionD <- getsState sfactionD
let assocsInGame = filter (inGame . snd) $ EM.assocs factionD
keysInGame = map fst assocsInGame
assocsSpawn = filter (isSpawnFact cops . snd) assocsInGame
assocsNotSummon = filter (not . isSummonFact cops . snd) assocsInGame
assocsUI = filter (playerUI . gplayer . snd) assocsInGame
case assocsNotSummon of
_ | null assocsUI ->
mapQuitF status{stOutcome=Conquer} keysInGame
[] ->
mapQuitF status{stOutcome=Conquer} keysInGame
(_, fact1) : rest | null assocsSpawn && all (isAllied fact1 . fst) rest ->
mapQuitF status{stOutcome=Conquer} keysInGame
_ | stOutcome status == Escape -> do
let (victors, losers) = partition (flip isAllied fid . snd) assocsInGame
mapQuitF status{stOutcome=Escape} $ map fst victors
mapQuitF status{stOutcome=Defeated} $ map fst losers
_ -> return ()
tryRestore :: MonadServer m
=> Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))
tryRestore Kind.COps{corule} sdebugSer = do
let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
prefix = ssavePrefixSer sdebugSer
(Config{ configAppDataDir
, configRulesCfgFile
, configScoresFile }, _, _) <- mkConfigRules corule Nothing
let copies =
[ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini")
, (configScoresFile, configScoresFile) ]
name = fromMaybe "save" prefix <.> saveName
liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile
childrenServer :: MVar [MVar ()]
childrenServer = unsafePerformIO (newMVar [])
updateConn :: (MonadAtomic m, MonadConnServer m)
=> (FactionId
-> Frontend.ChanFrontend
-> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId
-> ChanServer CmdClientAI CmdSerTakeTime
-> IO ())
-> m ()
updateConn executorUI executorAI = do
oldD <- getDict
let mkChanServer :: IO (ChanServer c d)
mkChanServer = do
fromServer <- STM.newTQueueIO
toServer <- STM.newTQueueIO
return ChanServer{..}
mkChanFrontend :: IO Frontend.ChanFrontend
mkChanFrontend = STM.newTQueueIO
addConn :: FactionId -> Faction -> IO ConnServerFaction
addConn fid fact = case EM.lookup fid oldD of
Just conns -> return conns
Nothing | playerUI $ gplayer fact -> do
connF <- mkChanFrontend
connS <- mkChanServer
connAI <- mkChanServer
return (Just (connF, connS), connAI)
Nothing -> do
connAI <- mkChanServer
return (Nothing, connAI)
factionD <- getsState sfactionD
d <- liftIO $ mapWithKeyM addConn factionD
let newD = d `EM.union` oldD
putDict newD
let toSpawn = newD EM.\\ oldD
fdict fid = ( fst
$ fromMaybe (assert `failure` "no channel" `twith` fid)
$ fst
$ fromMaybe (assert `failure` "no faction" `twith` fid)
$ EM.lookup fid newD
, maybe T.empty gname
$ EM.lookup fid factionD
)
fromM = Frontend.fromMulti Frontend.connMulti
liftIO $ void $ takeMVar fromM
let forkUI fid (connF, connS) =
void $ forkChild childrenServer $ executorUI fid connF connS
forkAI fid connS =
void $ forkChild childrenServer $ executorAI fid connS
forkClient fid (connUI, connAI) = do
forkAI fid connAI
maybe skip (forkUI fid) connUI
liftIO $ mapWithKeyM_ forkClient toSpawn
nU <- nUI
liftIO $ putMVar fromM (nU, fdict)
killAllClients :: (MonadAtomic m, MonadConnServer m) => m ()
killAllClients = do
d <- getDict
let sendKill fid _ = do
when (fromEnum fid > 0) $
sendUpdateUI fid $ CmdAtomicUI $ KillExitA fid
sendUpdateAI fid $ CmdAtomicAI $ KillExitA fid
mapWithKeyM_ sendKill d
speedupCOps :: Bool -> Kind.COps -> Kind.COps
speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =
let ospeedup = Tile.speedup allClear tile
cotile = tile {Kind.ospeedup = Just ospeedup}
in copsSlow {Kind.cotile = cotile}
rndToAction :: MonadServer m => Rnd a -> m a
rndToAction r = do
g <- getsServer srandom
let (a, ng) = St.runState r g
modifyServer $ \ser -> ser {srandom = ng}
return a
getSetGen :: ConfigIO.CP
-> String
-> Maybe R.StdGen
-> IO (R.StdGen, ConfigIO.CP)
getSetGen config option mrandom =
case ConfigIO.getOption config "engine" option of
Just sg -> return (read sg, config)
Nothing -> do
g <- case mrandom of
Just rnd -> return rnd
Nothing -> R.newStdGen
let gs = show g
c = ConfigIO.set config "engine" option gs
return (g, c)
parseConfigRules :: FilePath -> ConfigIO.CP -> Config
parseConfigRules dataDir cp =
let configSelfString = ConfigIO.to_string cp
configFirstDeathEnds = ConfigIO.get cp "engine" "firstDeathEnds"
configFovMode = ConfigIO.get cp "engine" "fovMode"
configSaveBkpClips = ConfigIO.get cp "engine" "saveBkpClips"
configAppDataDir = dataDir
configScoresFile = ConfigIO.get cp "file" "scoresFile"
configRulesCfgFile = "config.rules"
configSavePrefix = ConfigIO.get cp "file" "savePrefix"
configHeroNames =
let toNumber (ident, name) =
case stripPrefix "HeroName_" ident of
Just n -> (read n, T.pack name)
Nothing -> assert `failure` "wrong hero name id" `twith` ident
section = ConfigIO.getItems cp "heroName"
in map toNumber section
in Config{..}
mkConfigRules :: MonadServer m
=> Kind.Ops RuleKind -> Maybe R.StdGen
-> m (Config, R.StdGen, R.StdGen)
mkConfigRules corule mrandom = do
let cpRulesDefault = rcfgRulesDefault $ Kind.stdRuleset corule
dataDir <-
liftIO $ ConfigIO.appDataDir
cpRules <-
liftIO $ ConfigIO.mkConfig cpRulesDefault $ dataDir </> "config.rules.ini"
(dungeonGen, cp2) <-
liftIO $ getSetGen cpRules "dungeonRandomGenerator" mrandom
(startingGen, cp3) <-
liftIO $ getSetGen cp2 "startingRandomGenerator" mrandom
let conf = parseConfigRules dataDir cp3
return $! deepseq conf (conf, dungeonGen, startingGen)