    -- | 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