module Game.LambdaHack.Server.ProtocolServer
(
ChanServer(..)
, ConnServerDict
, MonadServerReadRequest
( getDict
, getsDict
, modifyDict
, putDict
, liftIO
)
, sendUpdateAI, sendQueryAI, sendPingAI
, sendUpdateUI, sendQueryUI, sendPingUI
, killAllClients, childrenServer, updateConn
#ifdef EXPOSE_INTERNAL
, ConnServerFaction
#endif
) where
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM (TQueue, atomically)
import qualified Control.Concurrent.STM as STM
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM, mapWithKeyM_)
import Data.Maybe
import Game.LambdaHack.Common.Thread
import System.IO.Unsafe (unsafePerformIO)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.Response
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Server.DebugServer
import Game.LambdaHack.Server.MonadServer hiding (liftIO)
import Game.LambdaHack.Server.State
data ChanServer resp req = ChanServer
{ responseS :: !(TQueue resp)
, requestS :: !(TQueue req)
}
type ConnServerFaction = ( Maybe (ChanServer ResponseUI RequestUI)
, ChanServer ResponseAI RequestAI )
type ConnServerDict = EM.EnumMap FactionId ConnServerFaction
class MonadServer m => MonadServerReadRequest m where
getDict :: m ConnServerDict
getsDict :: (ConnServerDict -> a) -> m a
modifyDict :: (ConnServerDict -> ConnServerDict) -> m ()
putDict :: ConnServerDict -> m ()
liftIO :: IO a -> m a
writeTQueueAI :: MonadServerReadRequest m
=> ResponseAI -> TQueue ResponseAI -> m ()
writeTQueueAI cmd responseS = do
debug <- getsServer $ sniffOut . sdebugSer
when debug $ debugResponseAI cmd
liftIO $ atomically $ STM.writeTQueue responseS cmd
writeTQueueUI :: MonadServerReadRequest m
=> ResponseUI -> TQueue ResponseUI -> m ()
writeTQueueUI cmd responseS = do
debug <- getsServer $ sniffOut . sdebugSer
when debug $ debugResponseUI cmd
liftIO $ atomically $ STM.writeTQueue responseS cmd
readTQueueAI :: MonadServerReadRequest m
=> TQueue RequestAI -> m RequestAI
readTQueueAI requestS = liftIO $ atomically $ STM.readTQueue requestS
readTQueueUI :: MonadServerReadRequest m
=> TQueue RequestUI -> m RequestUI
readTQueueUI requestS = liftIO $ atomically $ STM.readTQueue requestS
sendUpdateAI :: MonadServerReadRequest m
=> FactionId -> ResponseAI -> m ()
sendUpdateAI fid cmd = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI cmd $ responseS conn
sendQueryAI :: MonadServerReadRequest m
=> FactionId -> ActorId -> m RequestAI
sendQueryAI fid aid = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI (RespQueryAI aid) $ responseS conn
req <- readTQueueAI $ requestS conn
debug <- getsServer $ sniffIn . sdebugSer
when debug $ debugRequestAI aid req
return $! req
sendPingAI :: (MonadAtomic m, MonadServerReadRequest m)
=> FactionId -> m ()
sendPingAI fid = do
conn <- getsDict $ snd . (EM.! fid)
writeTQueueAI RespPingAI $ responseS conn
cmdPong <- readTQueueAI $ requestS conn
case cmdPong of
ReqAIPong -> return ()
_ -> assert `failure` (fid, cmdPong)
sendUpdateUI :: MonadServerReadRequest m
=> FactionId -> ResponseUI -> 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 $ responseS conn
sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)
=> FactionId -> ActorId -> m RequestUI
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 RespQueryUI $ responseS conn
req <- readTQueueUI $ requestS conn
debug <- getsServer $ sniffIn . sdebugSer
when debug $ debugRequestUI aid req
return $! req
sendPingUI :: (MonadAtomic m, MonadServerReadRequest 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 RespPingUI $ responseS conn
cmdPong <- readTQueueUI $ requestS conn
case cmdPong of
ReqUIPong ats -> mapM_ execAtomic ats
_ -> assert `failure` (fid, cmdPong)
killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()
killAllClients = do
d <- getDict
let sendKill fid cs = do
when (isJust $ fst cs) $
sendUpdateUI fid $ RespUpdAtomicUI $ UpdKillExit fid
sendUpdateAI fid $ RespUpdAtomicAI $ UpdKillExit fid
mapWithKeyM_ sendKill d
childrenServer :: MVar [Async ()]
childrenServer = unsafePerformIO (newMVar [])
updateConn :: (MonadAtomic m, MonadServerReadRequest m)
=> (FactionId
-> ChanServer ResponseUI RequestUI
-> IO ())
-> (FactionId
-> ChanServer ResponseAI RequestAI
-> IO ())
-> m ()
updateConn executorUI executorAI = do
oldD <- getDict
let mkChanServer :: IO (ChanServer resp req)
mkChanServer = do
responseS <- STM.newTQueueIO
requestS <- STM.newTQueueIO
return $! ChanServer{..}
addConn :: FactionId -> Faction -> IO ConnServerFaction
addConn fid fact = case EM.lookup fid oldD of
Just conns -> return conns
Nothing | fhasUI $ gplayer fact -> do
connS <- mkChanServer
connAI <- mkChanServer
return (Just 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
let forkUI fid connS =
forkChild childrenServer $ executorUI fid connS
forkAI fid connS =
forkChild childrenServer $ executorAI fid connS
forkClient fid (connUI, connAI) = do
forkAI fid connAI
maybe (return ()) (forkUI fid) connUI
liftIO $ mapWithKeyM_ forkClient toSpawn