-- | The server definitions for the server-client communication protocol.
module Game.LambdaHack.Server.ProtocolM
  ( -- * The communication channels
    CliSerQueue, ConnServerDict, ChanServer(..)
    -- * The server-client communication monad
  , MonadServerComm
      ( getsDict  -- exposed only to be implemented, not used
      , putDict  -- exposed only to be implemented, not used
      , liftIO  -- exposed only to be implemented, not used
      )
    -- * Protocol
  , sendUpdate, sendUpdateCheck, sendUpdNoState
  , sendSfx, sendQueryAI, sendQueryUI
    -- * Assorted
  , killAllClients, childrenServer, updateConn, tryRestore
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , writeQueue, readQueueAI, readQueueUI, newQueue
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import           Control.Concurrent.Async
import qualified Data.EnumMap.Strict as EM
import           Data.Key (mapWithKeyM_)
import           System.FilePath
import           System.IO.Unsafe (unsafePerformIO)

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Client (RequestAI, RequestUI, Response (..))
import           Game.LambdaHack.Common.ClientOptions (sbenchmark)
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.Common.Types
import           Game.LambdaHack.Content.FactionKind
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 :: MonadServerComm m
           => Response -> CliSerQueue Response -> m ()
{-# INLINE writeQueue #-}
writeQueue :: forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
cmd CliSerQueue Response
responseS = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CliSerQueue Response -> Response -> IO ()
forall a. MVar a -> a -> IO ()
putMVar CliSerQueue Response
responseS Response
cmd

readQueueAI :: MonadServerComm m
            => CliSerQueue RequestAI -> m RequestAI
{-# INLINE readQueueAI #-}
readQueueAI :: forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestAI -> m RequestAI
readQueueAI CliSerQueue RequestAI
requestS = IO RequestAI -> m RequestAI
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO RequestAI -> m RequestAI) -> IO RequestAI -> m RequestAI
forall a b. (a -> b) -> a -> b
$ CliSerQueue RequestAI -> IO RequestAI
forall a. MVar a -> IO a
takeMVar CliSerQueue RequestAI
requestS

readQueueUI :: MonadServerComm m
            => CliSerQueue RequestUI -> m RequestUI
{-# INLINE readQueueUI #-}
readQueueUI :: forall (m :: * -> *).
MonadServerComm m =>
CliSerQueue RequestUI -> m RequestUI
readQueueUI CliSerQueue RequestUI
requestS = IO RequestUI -> m RequestUI
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServerComm m => IO a -> m a
liftIO (IO RequestUI -> m RequestUI) -> IO RequestUI -> m RequestUI
forall a b. (a -> b) -> a -> b
$ CliSerQueue RequestUI -> IO RequestUI
forall a. MVar a -> IO a
takeMVar CliSerQueue RequestUI
requestS

newQueue :: IO (CliSerQueue a)
newQueue :: forall a. IO (CliSerQueue a)
newQueue = IO (MVar a)
forall a. IO (CliSerQueue a)
newEmptyMVar

type CliSerQueue = MVar

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

-- | Connection channel between the server and a single client.
data ChanServer = ChanServer
  { ChanServer -> CliSerQueue Response
responseS  :: CliSerQueue Response
  , ChanServer -> CliSerQueue RequestAI
requestAIS :: CliSerQueue RequestAI
  , ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS :: Maybe (CliSerQueue RequestUI)
  }

-- | The server monad with the ability to communicate with clients.
class MonadServer m => MonadServerComm m where
  getsDict       :: (ConnServerDict -> a) -> m a
  putDict        :: ConnServerDict -> m ()
  liftIO         :: IO a -> m a

getDict :: MonadServerComm m => m ConnServerDict
getDict :: forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict = (ConnServerDict -> ConnServerDict) -> m ConnServerDict
forall a. (ConnServerDict -> a) -> m a
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict ConnServerDict -> ConnServerDict
forall a. a -> a
id

-- | If the @AtomicFail@ conditions hold, send a command to client,
-- otherwise do nothing.
sendUpdate :: (MonadServerAtomic m, MonadServerComm m)
           => FactionId -> UpdAtomic -> m ()
sendUpdate :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
FactionId -> UpdAtomic -> m ()
sendUpdate !FactionId
fid !UpdAtomic
cmd = do
  succeeded <- FactionId -> UpdAtomic -> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> UpdAtomic -> m Bool
execUpdAtomicFidCatch FactionId
fid UpdAtomic
cmd
  when succeeded $ sendUpd fid cmd

-- | Send a command to client, crashing if the @AtomicFail@ conditions
-- don't hold when executed on the client's state.
sendUpdateCheck :: (MonadServerAtomic m, MonadServerComm m)
                => FactionId -> UpdAtomic -> m ()
sendUpdateCheck :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
FactionId -> UpdAtomic -> m ()
sendUpdateCheck !FactionId
fid !UpdAtomic
cmd = do
  FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> UpdAtomic -> m ()
execUpdAtomicFid FactionId
fid UpdAtomic
cmd
  FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpd FactionId
fid UpdAtomic
cmd

sendUpd :: MonadServerComm m => FactionId -> UpdAtomic -> m ()
sendUpd :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpd !FactionId
fid !UpdAtomic
cmd = do
  chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall a. (ConnServerDict -> a) -> m a
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
  s <- getsServer $ (EM.! fid) . sclientStates
  let resp = State -> UpdAtomic -> Response
RespUpdAtomic State
s UpdAtomic
cmd
  debug <- getsServer $ sniff . soptions
  when debug $ debugResponse fid resp
  writeQueue resp $ responseS chan

sendUpdNoState :: MonadServerComm m => FactionId -> UpdAtomic -> m ()
sendUpdNoState :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpdNoState !FactionId
fid !UpdAtomic
cmd = do
  chan <- (ConnServerDict -> ChanServer) -> m ChanServer
forall a. (ConnServerDict -> a) -> m a
forall (m :: * -> *) a.
MonadServerComm m =>
(ConnServerDict -> a) -> m a
getsDict (ConnServerDict -> FactionId -> ChanServer
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
  let resp = UpdAtomic -> Response
RespUpdAtomicNoState UpdAtomic
cmd
  debug <- getsServer $ sniff . soptions
  when debug $ debugResponse fid resp
  writeQueue resp $ responseS chan

sendSfx :: MonadServerComm m => FactionId -> SfxAtomic -> m ()
sendSfx :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> SfxAtomic -> m ()
sendSfx !FactionId
fid !SfxAtomic
sfx = do
  let resp :: Response
resp = SfxAtomic -> Response
RespSfxAtomic SfxAtomic
sfx
  debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  when debug $ debugResponse fid resp
  chan <- getsDict (EM.! fid)
  case chan of
    ChanServer{requestUIS :: ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS=Just{}} -> Response -> CliSerQueue Response -> m ()
forall (m :: * -> *).
MonadServerComm m =>
Response -> CliSerQueue Response -> m ()
writeQueue Response
resp (CliSerQueue Response -> m ()) -> CliSerQueue Response -> m ()
forall a b. (a -> b) -> a -> b
$ ChanServer -> CliSerQueue Response
responseS ChanServer
chan
    ChanServer
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI
sendQueryAI :: forall (m :: * -> *).
MonadServerComm m =>
FactionId -> ActorId -> m RequestAI
sendQueryAI FactionId
fid ActorId
aid = do
  let respAI :: Response
respAI = ActorId -> Response
RespQueryAI ActorId
aid
  debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
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, MonadServerComm m)
            => Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
Response -> FactionId -> ActorId -> m RequestUI
sendQueryUI Response
respUI FactionId
fid ActorId
_aid = do
  debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sniff (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
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, MonadServerComm m) => m ()
killAllClients :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
killAllClients = do
  d <- m ConnServerDict
forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict
  let sendKill FactionId
fid p
_ = FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> UpdAtomic -> m ()
sendUpdNoState FactionId
fid (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> UpdAtomic
UpdKillExit FactionId
fid
  -- We can't interate over sfactionD, because client can be from an old game.
  -- For the same reason we can't look up and send client's state.
  mapWithKeyM_ sendKill d

-- Global variable for all children threads of the server.
childrenServer :: MVar [Async ()]
{-# NOINLINE childrenServer #-}
childrenServer :: MVar [Async ()]
childrenServer = IO (MVar [Async ()]) -> MVar [Async ()]
forall a. IO a -> a
unsafePerformIO ([Async ()] -> IO (MVar [Async ()])
forall a. a -> IO (MVar a)
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 :: (MonadServerAtomic m, MonadServerComm m)
           => (FactionId -> ChanServer -> IO ())
           -> m ()
updateConn :: forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
(FactionId -> ChanServer -> IO ()) -> m ()
updateConn FactionId -> ChanServer -> IO ()
executorClient = do
  -- Prepare connections based on factions.
  oldD <- m ConnServerDict
forall (m :: * -> *). MonadServerComm m => m ConnServerDict
getDict
  let mkChanServer :: Faction -> IO ChanServer
      mkChanServer Faction
fact = do
        responseS <- IO (CliSerQueue Response)
forall a. IO (CliSerQueue a)
newQueue
        requestAIS <- newQueue
        requestUIS <- if fhasUI $ gkind fact
                      then assert (EM.null oldD) $ Just <$> newQueue
                      else return Nothing
        return ChanServer{..}
      forkClient FactionId
fid = MVar [Async ()] -> IO () -> IO ()
forkChild MVar [Async ()]
childrenServer (IO () -> IO ()) -> (ChanServer -> IO ()) -> ChanServer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> ChanServer -> IO ()
executorClient FactionId
fid
  factionD <- getsState sfactionD
  if EM.null oldD then do
    -- Easy case, nothing to recycle, frontend not spawned yet.
    newD <- liftIO $ mapM mkChanServer factionD
    putDict newD
    liftIO $ mapWithKeyM_ forkClient newD
  else do
    -- Hard case, but we know there is exactly one UI connection in oldD,
    -- so we can reuse it for any new UI faction (to keep history).
    -- UI session (history in particular) is preserved even over game
    -- save and reload. It gets saved with the savefile of the team
    -- that is a UI faction and restored intact. However, when a new game
    -- is started from commandline (@--newGame@), even if it's using the same
    -- save prefix (@--savePrefix@), the session data is often lost.
    -- AI factions don't care which client they use, so we don't always
    -- preserve the old assignments either of factions or teams.
    let -- Find the new UI faction.
        (fidUI, _) = fromJust $ find (fhasUI . gkind . snd) $ EM.assocs factionD
        -- Swap UI and AI connections around.
        swappedD = case ((FactionId, ChanServer) -> Bool)
-> [(FactionId, ChanServer)] -> Maybe (FactionId, ChanServer)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Maybe (CliSerQueue RequestUI) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CliSerQueue RequestUI) -> Bool)
-> ((FactionId, ChanServer) -> Maybe (CliSerQueue RequestUI))
-> (FactionId, ChanServer)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChanServer -> Maybe (CliSerQueue RequestUI)
requestUIS (ChanServer -> Maybe (CliSerQueue RequestUI))
-> ((FactionId, ChanServer) -> ChanServer)
-> (FactionId, ChanServer)
-> Maybe (CliSerQueue RequestUI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, ChanServer) -> ChanServer
forall a b. (a, b) -> b
snd)
                               ([(FactionId, ChanServer)] -> Maybe (FactionId, ChanServer))
-> [(FactionId, ChanServer)] -> Maybe (FactionId, ChanServer)
forall a b. (a -> b) -> a -> b
$ ConnServerDict -> [(FactionId, ChanServer)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ConnServerDict
oldD of
          Maybe (FactionId, ChanServer)
Nothing -> [Char] -> ConnServerDict
forall a. HasCallStack => [Char] -> a
error [Char]
"updateConn: no UI connection found"
          Just (FactionId
fid, ChanServer
conn) ->
            if FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fidUI
            then ConnServerDict
oldD  -- UI connection at the same place; nothing to do
            else let -- Move the AI connection that was at new UI faction spot,
                     -- to the freed old UI spot.
                     alt :: Maybe ChanServer -> Maybe ChanServer
alt Maybe ChanServer
_ = FactionId -> ConnServerDict -> Maybe ChanServer
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup FactionId
fidUI ConnServerDict
oldD
                 in (Maybe ChanServer -> Maybe ChanServer)
-> FactionId -> ConnServerDict -> ConnServerDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ChanServer -> Maybe ChanServer
alt FactionId
fid (ConnServerDict -> ConnServerDict)
-> ConnServerDict -> ConnServerDict
forall a b. (a -> b) -> a -> b
$ FactionId -> ChanServer -> ConnServerDict -> ConnServerDict
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fidUI ChanServer
conn ConnServerDict
oldD
        -- Add extra AI connections.
        extraFacts = (FactionId -> Faction -> Bool) -> FactionDict -> FactionDict
forall k a.
Enum k =>
(k -> a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filterWithKey (\FactionId
fid Faction
_ -> FactionId -> ConnServerDict -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
EM.notMember FactionId
fid ConnServerDict
swappedD)
                                      FactionDict
factionD
    extraD <- liftIO $ mapM mkChanServer extraFacts
    let exclusiveUnion = (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ((a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a)
-> (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"forbidden duplicate"
        newD = ConnServerDict
swappedD ConnServerDict -> ConnServerDict -> ConnServerDict
forall {k} {a}. EnumMap k a -> EnumMap k a -> EnumMap k a
`exclusiveUnion` ConnServerDict
extraD
    putDict newD
    -- Spawn the extra AI client threads.
    liftIO $ mapWithKeyM_ forkClient extraD

tryRestore :: MonadServerComm m => m (Maybe (State, StateServer))
tryRestore :: forall (m :: * -> *).
MonadServerComm m =>
m (Maybe (State, StateServer))
tryRestore = do
  COps{corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  soptions <- getsServer soptions
  if sbenchmark $ sclientOptions soptions then return Nothing
  else do
    let prefix = ServerOptions -> [Char]
ssavePrefixSer ServerOptions
soptions
        fileName = [Char]
prefix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> RuleContent -> [Char]
Save.saveNameSer RuleContent
corule
    res <- liftIO $ Save.restoreGame corule (sclientOptions soptions) fileName
    let cfgUIName = RuleContent -> [Char]
rcfgUIName RuleContent
corule
        (configText, _) = rcfgUIDefault corule
    dataDir <- liftIO appDataDir
    liftIO $ tryWriteFile (dataDir </> cfgUIName) configText
    return $! res