module Game.LambdaHack.Server.Action
(
MonadServer( getServer, getsServer, putServer, modifyServer, saveServer )
, MonadConnServer
, tryRestore, updateConn, killAllClients, speedupCOps
, sendUpdateAI, sendQueryAI, sendPingAI
, sendUpdateUI, sendQueryUI, sendPingUI
, debugPrint, dumpRngs
, getSetGen, restoreScore, revealItems, deduceQuits
, rndToAction, resetSessionStart, resetGameStart, elapsedSessionTimeGT
, tellAllClipPS, tellGameClipPS
, resetFidPerception, getPerFid
, childrenServer
) where
import Control.Concurrent
import Control.Concurrent.STM (TQueue, atomically)
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Ex hiding (handle)
import Control.Exception.Assert.Sugar
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 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.Save
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.Common.Time
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.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
per <- getsState
$ levelPerception cops (fromMaybe (Digital 12) fovMode) fid lid lvl
let 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
dumpRngs :: MonadServer m => m ()
dumpRngs = do
dataDir <- liftIO appDataDir
let fn = dataDir </> "rngs.dump"
rngs <- getsServer srngs
liftIO $ writeFile fn (show rngs)
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 CmdTakeTimeSer -> m CmdTakeTimeSer
readTQueueAI toServer = do
cmd <- liftIO $ atomically $ STM.readTQueue toServer
debug <- getsServer $ sniffIn . sdebugSer
when debug $ do
let aid = aidCmdTakeTimeSer cmd
d <- debugAid aid "CmdTakeTimeSer" 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 CmdTakeTimeSer
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 == CmdTakeTimeSer (WaitSer (toEnum (1)))) skip
restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable
restoreScore Kind.COps{corule} = do
let stdRuleset = Kind.stdRuleset corule
scoresFile = rscoresFile stdRuleset
dataDir <- liftIO appDataDir
let path = dataDir </> scoresFile
configExists <- liftIO $ doesFileExist path
mscore <- liftIO $ do
res <- Ex.try $
if configExists then do
s <- strictDecodeEOF path
return $ Just s
else return Nothing
let handler :: Ex.SomeException -> IO (Maybe a)
handler e = do
let msg = "High score restore failed. The error message is:"
<+> (T.unwords . T.lines) (tshow e)
delayPrint $ msg
return Nothing
either handler return res
maybe (return HighScore.empty) return mscore
registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()
registerScore status mbody fid = do
cops@Kind.COps{corule} <- getsState scops
assert (maybe True ((fid ==) . bfid) mbody) skip
fact <- getsState $ (EM.! fid) . sfactionD
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
let stdRuleset = Kind.stdRuleset corule
scoresFile = rscoresFile stdRuleset
dataDir <- liftIO appDataDir
table <- restoreScore cops
time <- getsState stime
date <- liftIO getClockTime
DebugModeSer{sdifficultySer} <- getsServer sdebugSer
let path = dataDir </> scoresFile
saveScore (ntable, _) =
liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)
diff | not $ playerUI $ gplayer fact = 0
| otherwise = sdifficultySer
maybe skip saveScore $ HighScore.register table total time status date diff
resetSessionStart :: MonadServer m => m ()
resetSessionStart = do
sstart <- liftIO getClockTime
modifyServer $ \ser -> ser {sstart}
resetGameStart :: MonadServer m => m ()
resetGameStart = do
sgstart <- liftIO getClockTime
time <- getsState stime
modifyServer $ \ser ->
ser {sgstart, sallTime = timeAdd (sallTime ser) time}
elapsedSessionTimeGT :: MonadServer m => Int -> m Bool
elapsedSessionTimeGT stopAfter = do
current <- liftIO getClockTime
TOD s p <- getsServer sstart
return $! TOD (s + fromIntegral stopAfter) p <= current
tellAllClipPS :: MonadServer m => m ()
tellAllClipPS = do
bench <- getsServer $ sbenchmark . sdebugSer
when bench $ do
TOD s p <- getsServer sstart
TOD sCur pCur <- liftIO getClockTime
allTime <- getsServer sallTime
gtime <- getsState stime
let time = timeAdd allTime gtime
let diff = fromIntegral sCur + fromIntegral pCur / 10e12
fromIntegral s fromIntegral p / 10e12
cps = fromIntegral (timeFit time timeClip) / diff :: Double
debugPrint $ "Session time:" <+> tshow diff <> "s."
<+> "Average clips per second:" <+> tshow cps <> "."
tellGameClipPS :: MonadServer m => m ()
tellGameClipPS = do
bench <- getsServer $ sbenchmark . sdebugSer
when bench $ do
TOD s p <- getsServer sgstart
unless (s == 0) $ do
TOD sCur pCur <- liftIO getClockTime
time <- getsState stime
let diff = fromIntegral sCur + fromIntegral pCur / 10e12
fromIntegral s fromIntegral p / 10e12
cps = fromIntegral (timeFit time timeClip) / diff :: Double
debugPrint $ "Game time:" <+> tshow diff <> "s."
<+> "Average clips per second:" <+> tshow cps <> "."
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
assocsNotHorror = filter (not . isHorrorFact cops . snd) assocsInGame
assocsUI = filter (playerUI . gplayer . snd) assocsInGame
case assocsNotHorror of
_ | null assocsUI ->
mapQuitF status{stOutcome=Conquer} keysInGame
[] ->
mapQuitF status{stOutcome=Conquer} keysInGame
(_, fact1) : rest | all (not . isAtWar 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 stdRuleset = Kind.stdRuleset corule
scoresFile = rscoresFile stdRuleset
pathsDataFile = rpathsDataFile stdRuleset
prefix = ssavePrefixSer sdebugSer
let copies = [( "GameDefinition" </> scoresFile
, scoresFile )]
name = fromMaybe "save" prefix <.> saveName
liftIO $ Save.restoreGame name copies pathsDataFile
childrenServer :: MVar [MVar ()]
childrenServer = unsafePerformIO (newMVar [])
updateConn :: (MonadAtomic m, MonadConnServer m)
=> (FactionId
-> Frontend.ChanFrontend
-> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId
-> ChanServer CmdClientAI CmdTakeTimeSer
-> 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 :: MonadServer m
=> Maybe R.StdGen
-> m R.StdGen
getSetGen mrng = case mrng of
Just rnd -> return rnd
Nothing -> liftIO $ R.newStdGen