ProtocolServer.hs

{-# LANGUAGE CPP #-}
-- | The server definitions for the server-client communication protocol.
module Game.LambdaHack.Server.ProtocolServer
  ( -- * The communication channels
    ChanServer(..)
  , ConnServerDict  -- exposed only to be implemented, not used
    -- * The server-client communication monad
  , MonadServerReadRequest
      ( getDict  -- exposed only to be implemented, not used
      , getsDict  -- exposed only to be implemented, not used
      , modifyDict  -- exposed only to be implemented, not used
      , putDict  -- exposed only to be implemented, not used
      , liftIO  -- exposed only to be implemented, not used
      )
    -- * Protocol
  , sendUpdateAI, sendQueryAI, sendPingAI
  , sendUpdateUI, sendQueryUI, sendPingUI
    -- * Assorted
  , killAllClients, childrenServer, updateConn
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , 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

-- | Connection channel between the server and a single client.
data ChanServer resp req = ChanServer
  { responseS :: !(TQueue resp)
  , requestS  :: !(TQueue req)
  }

-- | Connections to the human-controlled client of a faction and
-- to the AI client for the same faction.
type ConnServerFaction = ( Maybe (ChanServer ResponseUI RequestUI)
                         , ChanServer ResponseAI RequestAI )

-- | Connection information for all factions, indexed by faction identifier.
type ConnServerDict = EM.EnumMap FactionId ConnServerFaction

-- TODO: refactor so that the monad is split in 2 and looks analogously
-- to the Client monads. Restrict the Dict to implementation modules.
-- Then on top of that implement sendQueryAI, etc.
-- For now we call it MonadServerReadRequest
-- though it also has the functionality of MonadServerWriteResponse.

-- | The server monad with the ability to communicate with clients.
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
  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."
  cmdPong <- readTQueueAI $ requestS conn
  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."
  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
      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."
      cmdPong <- readTQueueUI $ requestS conn
      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."
      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
        -- We can't check in sfactionD, because client can be from an old game.
        when (isJust $ fst cs) $
          sendUpdateUI fid $ RespUpdAtomicUI $ UpdKillExit fid
        sendUpdateAI fid $ RespUpdAtomicAI $ UpdKillExit fid
  mapWithKeyM_ sendKill d

-- Global variable for all children threads of the server.
childrenServer :: MVar [Async ()]
{-# NOINLINE childrenServer #-}
childrenServer = unsafePerformIO (newMVar [])

-- | Update connections to the new definition of factions.
-- Connect to clients in old or newly spawned threads
-- that read and write directly to the channels.
updateConn :: (MonadAtomic m, MonadServerReadRequest m)
           => (FactionId
               -> ChanServer ResponseUI RequestUI
               -> IO ())
           -> (FactionId
               -> ChanServer ResponseAI RequestAI
               -> IO ())
           -> m ()
updateConn executorUI executorAI = do
  -- Prepare connections based on factions.
  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  -- share old conns and threads
        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  -- never kill old clients
  putDict newD
  -- Spawn client threads.
  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
        -- When a connection is reused, clients are not respawned,
        -- even if UI usage changes, but it works OK thanks to UI faction
        -- clients distinguished by positive FactionId numbers.
        forkAI fid connAI  -- AI clients always needed, e.g., for auto-explore
        maybe (return ()) (forkUI fid) connUI
  liftIO $ mapWithKeyM_ forkClient toSpawn