module Game.LambdaHack.Server.Action
(
MonadServer( getServer, getsServer, putServer, modifyServer )
, MonadConnServer
, tryRestore, updateConn, killAllClients, waitForChildren, speedupCOps
, sendUpdateUI, sendQueryUI, sendUpdateAI, sendQueryAI
, saveGameSer, saveGameBkp, dumpCfg
, mkConfigRules, restoreScore, revealItems, deduceQuits
, rndToAction, fovMode, resetFidPerception, getPerFid
) where
import Control.Concurrent
import Control.Concurrent.STM (TQueue, atomically, newTQueueIO)
import qualified Control.Concurrent.STM as STM
import Control.Exception (finally)
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 qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Directory
import System.IO (stderr)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random as R
import System.Time
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 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.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Frontend as Frontend
import Game.LambdaHack.Server.Action.ActionClass
import qualified Game.LambdaHack.Server.Action.ConfigIO as ConfigIO
import qualified Game.LambdaHack.Server.Action.Save as Save
import Game.LambdaHack.Server.Config
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.State
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.File
fovMode :: MonadServer m => m FovMode
fovMode = do
configFovMode <- getsServer (configFovMode . sconfig)
sdebugSer <- getsServer sdebugSer
return $ fromMaybe configFovMode $ stryFov sdebugSer
resetFidPerception :: MonadServer m => FactionId -> LevelId -> m ()
resetFidPerception fid lid = do
cops <- getsState scops
lvl <- getsLevel lid id
configFov <- fovMode
s <- getState
let per = levelPerception cops s configFov 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` (lid, fid)) $ EM.lookup fid pers
per = fromMaybe (assert `failure` (lid, fid)) $ EM.lookup lid fper
return $! per
saveGameSer :: MonadServer m => m ()
saveGameSer = do
s <- getState
ser <- getServer
config <- getsServer sconfig
liftIO $ Save.saveGameSer config s ser
saveGameBkp :: MonadServer m => m ()
saveGameBkp = do
s <- getState
ser <- getServer
config <- getsServer sconfig
liftIO $ Save.saveGameBkpSer config s ser
dumpCfg :: MonadServer m => FilePath -> m ()
dumpCfg fn = do
config <- getsServer sconfig
liftIO $ ConfigIO.dump config 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
readTQueue :: MonadConnServer m => TQueue CmdSer -> m CmdSer
readTQueue toServer = do
cmd <- liftIO $ atomically $ STM.readTQueue toServer
debug <- getsServer $ sniffIn . sdebugSer
when debug $ do
let aid = aidCmdSer cmd
d <- debugAid aid (showT ("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 CmdSer
sendQueryAI fid aid = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI (CmdQueryAI aid) $ fromServer conn
readTQueue $ toServer conn
sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m ()
sendUpdateUI fid cmd = do
conn <- getsDict $ snd . fst . (EM.! fid)
writeTQueueUI cmd $ fromServer conn
sendQueryUI :: MonadConnServer m => FactionId -> ActorId -> m CmdSer
sendQueryUI fid aid = do
conn <- getsDict $ snd . fst . (EM.! fid)
writeTQueueUI (CmdQueryUI aid) $ fromServer conn
readTQueue $ toServer conn
mkConfigRules :: MonadServer m
=> Kind.Ops RuleKind -> m (Config, R.StdGen, R.StdGen)
mkConfigRules = liftIO . ConfigIO.mkConfigRules
restoreScore :: MonadServer m => Config -> m HighScore.ScoreTable
restoreScore Config{configScoresFile} = do
b <- liftIO $ doesFileExist configScoresFile
if not b
then return HighScore.empty
else liftIO $ strictDecodeEOF configScoresFile
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 (isHumanFact 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 <- getsServer sconfig
table <- restoreScore config
time <- getsState stime
date <- liftIO getClockTime
let saveScore (ntable, _) =
liftIO $ encodeEOF (configScoresFile config)
(ntable :: HighScore.ScoreTable)
maybe skip saveScore $ HighScore.register table total time status date
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 (isHumanFact fact) $ do
revealItems (Just fid) mbody
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{stOutcome=Defeated} = assert `failure` body
deduceQuits body Status{stOutcome=Camping} = assert `failure` body
deduceQuits body Status{stOutcome=Restart} = assert `failure` body
deduceQuits body Status{stOutcome=Conquer} = assert `failure` 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
assocsHuman = filter (isHumanFact . snd) assocsInGame
case assocsNotSummon of
_ | null assocsHuman ->
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 -> m (Maybe (State, StateServer))
tryRestore Kind.COps{corule} = do
let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
(sconfig, _, _) <- mkConfigRules corule
liftIO $ Save.restoreGameSer sconfig pathsDataFile
updateConn :: (MonadAtomic m, MonadConnServer m)
=> (FactionId -> Frontend.ChanFrontend -> ChanServer CmdClientUI
-> IO ())
-> (FactionId -> ChanServer CmdClientAI -> IO ())
-> m ()
updateConn executorUI executorAI = do
oldD <- getDict
let mkChanServer :: IO (ChanServer c)
mkChanServer = do
fromServer <- newTQueueIO
toServer <- newTQueueIO
return ChanServer{..}
mkChanFrontend :: IO Frontend.ChanFrontend
mkChanFrontend = newTQueueIO
addConn fid _ = case EM.lookup fid oldD of
Just conns -> return conns
Nothing -> do
connF <- mkChanFrontend
connS <- mkChanServer
connAI <- mkChanServer
return ((connF, connS), 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 $ fst
$ fromMaybe (assert `failure` 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 $ executorUI fid connF connS
forkAI fid connS = void $ forkChild $ executorAI fid connS
forkClient fid (connUI, connAI) = do
when (isHumanFact $ factionD EM.! fid) $ forkUI fid connUI
when (usesAIFact $ factionD EM.! fid) $ forkAI fid connAI
liftIO $ mapWithKeyM_ forkClient toSpawn
nH <- nHumans
liftIO $ putMVar fromM (nH, fdict)
killAllClients :: (MonadAtomic m, MonadConnServer m) => m ()
killAllClients = do
d <- getDict
let sendKill fid _ = do
sendUpdateUI fid $ CmdAtomicUI $ KillExitA fid
sendUpdateAI fid $ CmdAtomicAI $ KillExitA fid
mapWithKeyM_ sendKill d
children :: MVar [MVar ()]
children = unsafePerformIO (newMVar [])
waitForChildren :: IO ()
waitForChildren = do
cs <- takeMVar children
case cs of
[] -> return ()
m : ms -> do
putMVar children ms
takeMVar m
waitForChildren
forkChild :: IO () -> IO ThreadId
forkChild io = do
mvar <- newEmptyMVar
childs <- takeMVar children
putMVar children (mvar : childs)
forkIO (io `finally` putMVar mvar ())
speedupCOps :: Bool -> Kind.COps -> Kind.COps
speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =
let ospeedup = Tile.speedup allClear tile
cotile = tile {Kind.ospeedup = 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