module Game.LambdaHack.Server.ProtocolM
(
CliSerQueue, ConnServerDict, ChanServer(..)
, MonadServerReadRequest
( getsDict
, modifyDict
, liftIO
)
, putDict, sendUpdate, sendUpdateCheck, sendUpdNoState
, sendSfx, sendQueryAI, sendQueryUI
, killAllClients, childrenServer, updateConn, tryRestore
#ifdef EXPOSE_INTERNAL
, writeQueue, readQueueAI, readQueueUI, newQueue
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM, mapWithKeyM_)
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.File
import Game.LambdaHack.Common.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.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.DebugM
import Game.LambdaHack.Server.MonadServer hiding (liftIO)
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
writeQueue :: MonadServerReadRequest m
=> Response -> CliSerQueue Response -> m ()
{-# INLINE writeQueue #-}
writeQueue cmd responseS = liftIO $ putMVar responseS cmd
readQueueAI :: MonadServerReadRequest m
=> CliSerQueue RequestAI -> m RequestAI
{-# INLINE readQueueAI #-}
readQueueAI requestS = liftIO $ takeMVar requestS
readQueueUI :: MonadServerReadRequest m
=> CliSerQueue RequestUI -> m RequestUI
{-# INLINE readQueueUI #-}
readQueueUI requestS = liftIO $ takeMVar requestS
newQueue :: IO (CliSerQueue a)
newQueue = newEmptyMVar
type CliSerQueue = MVar
type ConnServerDict = EM.EnumMap FactionId ChanServer
data ChanServer = ChanServer
{ responseS :: CliSerQueue Response
, requestAIS :: CliSerQueue RequestAI
, requestUIS :: Maybe (CliSerQueue RequestUI)
}
class MonadServer m => MonadServerReadRequest m where
getsDict :: (ConnServerDict -> a) -> m a
modifyDict :: (ConnServerDict -> ConnServerDict) -> m ()
liftIO :: IO a -> m a
getDict :: MonadServerReadRequest m => m ConnServerDict
getDict = getsDict id
putDict :: MonadServerReadRequest m => ConnServerDict -> m ()
putDict s = modifyDict (const s)
sendUpdate :: (MonadServerAtomic m, MonadServerReadRequest m)
=> FactionId -> UpdAtomic -> m ()
sendUpdate !fid !cmd = do
succeeded <- execUpdAtomicFidCatch fid cmd
when succeeded $ sendUpd fid cmd
sendUpdateCheck :: (MonadServerAtomic m, MonadServerReadRequest m)
=> FactionId -> UpdAtomic -> m ()
sendUpdateCheck !fid !cmd = do
execUpdAtomicFid fid cmd
sendUpd fid cmd
sendUpd :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m ()
sendUpd !fid !cmd = do
chan <- getsDict (EM.! fid)
s <- getsServer $ (EM.! fid) . sclientStates
let resp = RespUpdAtomic s cmd
debug <- getsServer $ sniff . soptions
when debug $ debugResponse fid resp
writeQueue resp $ responseS chan
sendUpdNoState :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m ()
sendUpdNoState !fid !cmd = do
chan <- getsDict (EM.! fid)
let resp = RespUpdAtomicNoState cmd
debug <- getsServer $ sniff . soptions
when debug $ debugResponse fid resp
writeQueue resp $ responseS chan
sendSfx :: MonadServerReadRequest m => FactionId -> SfxAtomic -> m ()
sendSfx !fid !sfx = do
let resp = RespSfxAtomic sfx
debug <- getsServer $ sniff . soptions
when debug $ debugResponse fid resp
chan <- getsDict (EM.! fid)
case chan of
ChanServer{requestUIS=Just{}} -> writeQueue resp $ responseS chan
_ -> return ()
sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI
sendQueryAI fid aid = do
let respAI = RespQueryAI aid
debug <- getsServer $ sniff . soptions
when debug $ debugResponse fid respAI
chan <- getsDict (EM.! fid)
req <- do
writeQueue respAI $ responseS chan
readQueueAI $ requestAIS chan
when debug $ debugRequestAI aid
return req
sendQueryUI :: (MonadServerAtomic m, MonadServerReadRequest m)
=> FactionId -> ActorId -> m RequestUI
sendQueryUI fid _aid = do
let respUI = RespQueryUI
debug <- getsServer $ sniff . soptions
when debug $ debugResponse fid respUI
chan <- getsDict (EM.! fid)
req <- do
writeQueue respUI $ responseS chan
readQueueUI $ fromJust $ requestUIS chan
when debug $ debugRequestUI _aid
return req
killAllClients :: (MonadServerAtomic m, MonadServerReadRequest m) => m ()
killAllClients = do
d <- getDict
let sendKill fid _ = sendUpdNoState fid $ UpdKillExit fid
mapWithKeyM_ sendKill d
childrenServer :: MVar [Async ()]
{-# NOINLINE childrenServer #-}
childrenServer = unsafePerformIO (newMVar [])
updateConn :: (MonadServerAtomic m, MonadServerReadRequest m)
=> (Bool -> FactionId -> ChanServer -> IO ())
-> m ()
updateConn executorClient = do
oldD <- getDict
let mkChanServer :: Faction -> IO ChanServer
mkChanServer fact = do
responseS <- newQueue
requestAIS <- newQueue
requestUIS <- if fhasUI $ gplayer fact
then Just <$> newQueue
else return Nothing
return $! ChanServer{..}
addConn :: FactionId -> Faction -> IO ChanServer
addConn fid fact = case EM.lookup fid oldD of
Just conns -> return conns
Nothing -> mkChanServer fact
factionD <- getsState sfactionD
d <- liftIO $ mapWithKeyM addConn factionD
let newD = d `EM.union` oldD
putDict newD
let toSpawn = newD EM.\\ oldD
forkUI fid connS =
forkChild childrenServer $ executorClient True fid connS
forkAI fid connS =
forkChild childrenServer $ executorClient False fid connS
forkClient fid conn@ChanServer{requestUIS=Nothing} =
forkAI fid conn
forkClient fid conn =
forkUI fid conn
liftIO $ mapWithKeyM_ forkClient toSpawn
tryRestore :: MonadServerReadRequest m => m (Maybe (State, StateServer))
tryRestore = do
cops <- getsState scops
soptions <- getsServer soptions
let bench = sbenchmark $ sclientOptions soptions
if bench then return Nothing
else do
let prefix = ssavePrefixSer soptions
fileName = prefix <> Save.saveNameSer cops
res <- liftIO $ Save.restoreGame cops fileName
let stdRuleset = getStdRuleset cops
cfgUIName = rcfgUIName stdRuleset
content = rcfgUIDefault stdRuleset
dataDir <- liftIO appDataDir
liftIO $ tryWriteFile (dataDir </> cfgUIName) content
return $! res