module Game.LambdaHack.Server.ProtocolM
(
ConnServerDict
, MonadServerReadRequest
( getsDict
, modifyDict
, liftIO
)
, putDict, sendUpdate, sendSfx, sendQueryAI, sendQueryUI
, killAllClients, childrenServer, updateConn, tryRestore
#ifdef EXPOSE_INTERNAL
#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 (Config, SessionUI, emptySessionUI)
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.File
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.Response
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.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
tryRestore :: MonadServerReadRequest m
=> Kind.COps -> DebugModeSer
-> m (Maybe (State, StateServer))
tryRestore cops@Kind.COps{corule} sdebugSer = do
let bench = sbenchmark $ sdebugCli sdebugSer
if bench then return Nothing
else do
let prefix = ssavePrefixSer sdebugSer
fileName = prefix <> Save.saveNameSer cops
res <- liftIO $ Save.restoreGame cops fileName
let stdRuleset = Kind.stdRuleset corule
cfgUIName = rcfgUIName stdRuleset
content = rcfgUIDefault stdRuleset
dataDir <- liftIO appDataDir
liftIO $ tryWriteFile (dataDir </> cfgUIName) content
return $! res
type ConnServerDict = EM.EnumMap FactionId ChanServer
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 :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m ()
sendUpdate !fid !cmd = do
chan <- getsDict (EM.! fid)
let resp = RespUpdAtomic cmd
debug <- getsServer $ sniffOut . sdebugSer
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 $ sniffOut . sdebugSer
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 $ sniffOut . sdebugSer
when debug $ debugResponse fid respAI
chan <- getsDict (EM.! fid)
req <- do
writeQueue respAI $ responseS chan
readQueueAI $ requestAIS chan
when debug $ debugRequestAI aid req
return req
sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)
=> FactionId -> ActorId -> m RequestUI
sendQueryUI fid _aid = do
let respUI = RespQueryUI
debug <- getsServer $ sniffOut . sdebugSer
when debug $ debugResponse fid respUI
chan <- getsDict (EM.! fid)
req <- do
writeQueue respUI $ responseS chan
readQueueUI $ fromJust $ requestUIS chan
when debug $ debugRequestUI _aid req
return req
killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()
killAllClients = do
d <- getDict
let sendKill fid _ =
sendUpdate fid $ UpdKillExit fid
mapWithKeyM_ sendKill d
childrenServer :: MVar [Async ()]
{-# NOINLINE childrenServer #-}
childrenServer = unsafePerformIO (newMVar [])
updateConn :: (MonadAtomic m, MonadServerReadRequest m)
=> Config
-> (Maybe SessionUI -> FactionId -> ChanServer -> IO ())
-> m ()
updateConn sconfig executorClient = do
oldD <- getDict
let sess = emptySessionUI sconfig
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 (Just sess) fid connS
forkAI fid connS =
forkChild childrenServer $ executorClient Nothing fid connS
forkClient fid conn@ChanServer{requestUIS=Nothing} =
forkAI fid conn
forkClient fid conn =
forkUI fid conn
liftIO $ mapWithKeyM_ forkClient toSpawn