{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Rollback and replay based game networking
module Alpaca.NetCode.Internal.Server
  ( runServerWith'
  , ServerConfig (..)
  , defaultServerConfig
  ) where

import Control.Applicative
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.STM as STM
import Control.Monad (forM_, forever, join, when, forM)
import Data.Coerce (coerce)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.List (dropWhileEnd, foldl')
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Time (getCurrentTime)
import Flat
import Prelude

import Alpaca.NetCode.Internal.Common

-- | Configuration options specific to the server.
data ServerConfig = ServerConfig
  {
  -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same
  -- across all clients and the server. Packet rate and hence network bandwidth
  -- will scale linearly with this the tick rate.
    ServerConfig -> Int
scTickRate :: Int
  -- | Seconds of not receiving packets from a client before disconnecting that
  -- client.
  , ServerConfig -> Float
scClientTimeout :: Float
  } deriving (Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
(Int -> ServerConfig -> ShowS)
-> (ServerConfig -> String)
-> ([ServerConfig] -> ShowS)
-> Show ServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerConfig] -> ShowS
$cshowList :: [ServerConfig] -> ShowS
show :: ServerConfig -> String
$cshow :: ServerConfig -> String
showsPrec :: Int -> ServerConfig -> ShowS
$cshowsPrec :: Int -> ServerConfig -> ShowS
Show, ReadPrec [ServerConfig]
ReadPrec ServerConfig
Int -> ReadS ServerConfig
ReadS [ServerConfig]
(Int -> ReadS ServerConfig)
-> ReadS [ServerConfig]
-> ReadPrec ServerConfig
-> ReadPrec [ServerConfig]
-> Read ServerConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ServerConfig]
$creadListPrec :: ReadPrec [ServerConfig]
readPrec :: ReadPrec ServerConfig
$creadPrec :: ReadPrec ServerConfig
readList :: ReadS [ServerConfig]
$creadList :: ReadS [ServerConfig]
readsPrec :: Int -> ReadS ServerConfig
$creadsPrec :: Int -> ReadS ServerConfig
Read, ServerConfig -> ServerConfig -> Bool
(ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> Bool) -> Eq ServerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerConfig -> ServerConfig -> Bool
$c/= :: ServerConfig -> ServerConfig -> Bool
== :: ServerConfig -> ServerConfig -> Bool
$c== :: ServerConfig -> ServerConfig -> Bool
Eq, Eq ServerConfig
Eq ServerConfig
-> (ServerConfig -> ServerConfig -> Ordering)
-> (ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> ServerConfig)
-> (ServerConfig -> ServerConfig -> ServerConfig)
-> Ord ServerConfig
ServerConfig -> ServerConfig -> Bool
ServerConfig -> ServerConfig -> Ordering
ServerConfig -> ServerConfig -> ServerConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ServerConfig -> ServerConfig -> ServerConfig
$cmin :: ServerConfig -> ServerConfig -> ServerConfig
max :: ServerConfig -> ServerConfig -> ServerConfig
$cmax :: ServerConfig -> ServerConfig -> ServerConfig
>= :: ServerConfig -> ServerConfig -> Bool
$c>= :: ServerConfig -> ServerConfig -> Bool
> :: ServerConfig -> ServerConfig -> Bool
$c> :: ServerConfig -> ServerConfig -> Bool
<= :: ServerConfig -> ServerConfig -> Bool
$c<= :: ServerConfig -> ServerConfig -> Bool
< :: ServerConfig -> ServerConfig -> Bool
$c< :: ServerConfig -> ServerConfig -> Bool
compare :: ServerConfig -> ServerConfig -> Ordering
$ccompare :: ServerConfig -> ServerConfig -> Ordering
$cp1Ord :: Eq ServerConfig
Ord)

-- | Sensible defaults for @ServerConfig@ based on the tick rate.
defaultServerConfig ::
  -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same
  -- across all clients and the server. Packet rate and hence network bandwidth
  -- will scale linearly with this the tick rate.
  Int
  -> ServerConfig
defaultServerConfig :: Int -> ServerConfig
defaultServerConfig Int
tickRate = ServerConfig :: Int -> Float -> ServerConfig
ServerConfig
  { scTickRate :: Int
scTickRate = Int
tickRate
  , scClientTimeout :: Float
scClientTimeout = Float
5
  }

-- | Run a server for a single game. This will block until the game ends,
-- specifically when all players have disconnected.
runServerWith' ::
  forall input clientAddress.
  ( Eq input
  , Flat input
  , Show clientAddress
  , Ord clientAddress
  ) =>
  -- | Function to send messages to clients. The underlying communication
  -- protocol need only guarantee data integrity but is otherwise free to drop
  -- and reorder packets. Typically this is backed by a UDP socket.
  (NetMsg input -> clientAddress -> IO ()) ->
  -- | Blocking function to receive messages from the clients. Has the same
  -- reliability requirements as the send function.
  (IO (NetMsg input, clientAddress)) ->
  -- | Optional simulation of network conditions. In production this should be
  -- `Nothing`. May differ between clients.
  Maybe SimNetConditions ->
  -- | The 'defaultServerConfig' works well for most cases.
  ServerConfig ->
  -- | Initial input for new players. Must be the same across all clients and
  -- the server. See 'Alpaca.NetCode.runClient'.
  input ->
  IO ()
runServerWith' :: (NetMsg input -> clientAddress -> IO ())
-> IO (NetMsg input, clientAddress)
-> Maybe SimNetConditions
-> ServerConfig
-> input
-> IO ()
runServerWith' NetMsg input -> clientAddress -> IO ()
sendToClient' IO (NetMsg input, clientAddress)
recvFromClient' Maybe SimNetConditions
simNetConditionsMay ServerConfig
serverConfig input
input0 = Int -> (Float -> IO Float -> (UTCTime -> STM ()) -> IO ()) -> IO ()
forall a b.
Real a =>
a -> (Float -> IO Float -> (UTCTime -> STM ()) -> IO b) -> IO b
playCommon (ServerConfig -> Int
scTickRate ServerConfig
serverConfig) ((Float -> IO Float -> (UTCTime -> STM ()) -> IO ()) -> IO ())
-> (Float -> IO Float -> (UTCTime -> STM ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Float
tickTime IO Float
getTime UTCTime -> STM ()
resetTime -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  ((NetMsg input, clientAddress) -> IO ()
sendToClient'', IO (NetMsg input, clientAddress)
recvFromClient) <- ((NetMsg input, clientAddress) -> IO ())
-> IO (NetMsg input, clientAddress)
-> Maybe SimNetConditions
-> IO
     ((NetMsg input, clientAddress) -> IO (),
      IO (NetMsg input, clientAddress))
forall msg.
(msg -> IO ())
-> IO msg -> Maybe SimNetConditions -> IO (msg -> IO (), IO msg)
simulateNetConditions
    ((NetMsg input -> clientAddress -> IO ())
-> (NetMsg input, clientAddress) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NetMsg input -> clientAddress -> IO ()
sendToClient')
    IO (NetMsg input, clientAddress)
recvFromClient'
    Maybe SimNetConditions
simNetConditionsMay
  let sendToClient :: NetMsg input -> clientAddress -> IO ()
sendToClient = ((NetMsg input, clientAddress) -> IO ())
-> NetMsg input -> clientAddress -> IO ()
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (NetMsg input, clientAddress) -> IO ()
sendToClient''
  String -> IO ()
debugStrLn String
"Waiting for clients"

  -- Authoritative Map from tick and PlayerId to inputs. The inner map is
  -- always complete (e.g. if we have the IntMap for tick i, then it contains
  -- the inputs for *all* known players)
  TVar (IntMap (Map PlayerId input))
authInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- IntMap (Map PlayerId input)
-> IO (TVar (IntMap (Map PlayerId input)))
forall a. a -> IO (TVar a)
newTVarIO (Int -> Map PlayerId input -> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a
IM.singleton Int
0 Map PlayerId input
forall k a. Map k a
M.empty)

  -- The next Tick i.e. the first non-frozen tick. All ticks before this
  -- one have been frozen (w.r.t authInputsTVar).
  TVar Tick
nextTickTVar :: TVar Tick <- Tick -> IO (TVar Tick)
forall a. a -> IO (TVar a)
newTVarIO Tick
1

  -- Known players as of now. Nothing means the host (me).
  TVar (Map clientAddress PlayerData)
playersTVar :: TVar (M.Map clientAddress PlayerData) <- Map clientAddress PlayerData
-> IO (TVar (Map clientAddress PlayerData))
forall a. a -> IO (TVar a)
newTVarIO Map clientAddress PlayerData
forall k a. Map k a
M.empty
  -- Known Players (
  --               , last time for which a message was received
  --               )

  -- Next available PlayerId
  TVar PlayerId
nextPlayerIdTVar :: TVar PlayerId <- PlayerId -> IO (TVar PlayerId)
forall a. a -> IO (TVar a)
newTVarIO PlayerId
0

  -- As the host we're authoritative and always simulating significantly
  -- behind clients. This allows for ample time to receive inputs even
  -- with large ping and jitter. Although the authoritative simulation is
  -- significantly behind clients, we send input hints eagerly, and that
  -- allows clients to make accurate predictions and hence they don't
  -- perceive the lag in authoritative inputs.

  -- Main message processing loop
  ThreadId
msgProcessingTID <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (NetMsg input
msg, clientAddress
sender) <- IO (NetMsg input, clientAddress)
recvFromClient

      -- Handle the message
      Maybe Float
serverReceiveTimeMay <- case NetMsg input
msg of
        Msg_Connected{} -> do
          String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server received unexpected Msg_Connected from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Ignoring."
          Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Float
forall a. Maybe a
Nothing
        Msg_AuthInput{} -> do
          String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server received unexpected Msg_AuthInput from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Ignoring."
          Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Float
forall a. Maybe a
Nothing
        Msg_HeartbeatResponse{} -> do
          String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server received unexpected Msg_HeartbeatResponse from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Ignoring."
          Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Float
forall a. Maybe a
Nothing
        Msg_HintInput{} -> do
          String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server received unexpected Msg_HintInput from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Perhaps you meant to send a Msg_SubmitInput. Ignoring."
          Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Float
forall a. Maybe a
Nothing
        Msg_Connect Float
clientSendTime -> do
          -- new client connection
          UTCTime
currentTimeUTC <- IO UTCTime
getCurrentTime
          Float
currentTime <- IO Float
getTime
          IO (IO (Maybe Float)) -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe Float)) -> IO (Maybe Float))
-> IO (IO (Maybe Float)) -> IO (Maybe Float)
forall a b. (a -> b) -> a -> b
$
            STM (IO (Maybe Float)) -> IO (IO (Maybe Float))
forall a. STM a -> IO a
atomically (STM (IO (Maybe Float)) -> IO (IO (Maybe Float)))
-> STM (IO (Maybe Float)) -> IO (IO (Maybe Float))
forall a b. (a -> b) -> a -> b
$ do
              Maybe PlayerData
playerMay <- clientAddress -> Map clientAddress PlayerData -> Maybe PlayerData
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup clientAddress
sender (Map clientAddress PlayerData -> Maybe PlayerData)
-> STM (Map clientAddress PlayerData) -> STM (Maybe PlayerData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
              (PlayerId
pid, Maybe String
debugMsg, Float
serverReceiveTime) <- case Maybe PlayerData
playerMay of
                Maybe PlayerData
Nothing -> do
                  -- New player
                  PlayerId
pid <- TVar PlayerId -> STM PlayerId
forall a. TVar a -> STM a
readTVar TVar PlayerId
nextPlayerIdTVar
                  TVar PlayerId -> PlayerId -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PlayerId
nextPlayerIdTVar (PlayerId
pid PlayerId -> PlayerId -> PlayerId
forall a. Num a => a -> a -> a
+ PlayerId
1)
                  Map clientAddress PlayerData
players <- TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
                  let isFirstConnection :: Bool
isFirstConnection = Map clientAddress PlayerData -> Bool
forall k a. Map k a -> Bool
M.null Map clientAddress PlayerData
players
                  -- We only start the game on first connection, so must reset the timer
                  Float
serverReceiveTime <-
                    if Bool
isFirstConnection
                      then do
                        UTCTime -> STM ()
resetTime UTCTime
currentTimeUTC
                        Float -> STM Float
forall (m :: * -> *) a. Monad m => a -> m a
return Float
0
                      else Float -> STM Float
forall (m :: * -> *) a. Monad m => a -> m a
return Float
currentTime
                  TVar (Map clientAddress PlayerData)
-> Map clientAddress PlayerData -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map clientAddress PlayerData)
playersTVar (clientAddress
-> PlayerData
-> Map clientAddress PlayerData
-> Map clientAddress PlayerData
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert clientAddress
sender (PlayerData :: PlayerId -> Tick -> Float -> PlayerData
PlayerData{playerId :: PlayerId
playerId = PlayerId
pid, maxAuthTick :: Tick
maxAuthTick = Tick
0, lastMesgRcvTime :: Float
lastMesgRcvTime = Float
serverReceiveTime}) Map clientAddress PlayerData
players)
                  (PlayerId, Maybe String, Float)
-> STM (PlayerId, Maybe String, Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlayerId
pid, String -> Maybe String
forall a. a -> Maybe a
Just (String
"Connected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" as " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
pid), Float
serverReceiveTime)
                Just PlayerData{Float
PlayerId
Tick
lastMesgRcvTime :: Float
maxAuthTick :: Tick
playerId :: PlayerId
lastMesgRcvTime :: PlayerData -> Float
maxAuthTick :: PlayerData -> Tick
playerId :: PlayerData -> PlayerId
..} -> do
                  -- Existing player
                  (PlayerId, Maybe String, Float)
-> STM (PlayerId, Maybe String, Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlayerId
playerId, Maybe String
forall a. Maybe a
Nothing, Float
currentTime)
              IO (Maybe Float) -> STM (IO (Maybe Float))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe Float) -> STM (IO (Maybe Float)))
-> IO (Maybe Float) -> STM (IO (Maybe Float))
forall a b. (a -> b) -> a -> b
$ do
                NetMsg input -> clientAddress -> IO ()
sendToClient (PlayerId -> NetMsg input
forall input. PlayerId -> NetMsg input
Msg_Connected PlayerId
pid) clientAddress
sender
                NetMsg input -> clientAddress -> IO ()
sendToClient (Float -> Float -> NetMsg input
forall input. Float -> Float -> NetMsg input
Msg_HeartbeatResponse Float
clientSendTime Float
serverReceiveTime) clientAddress
sender
                (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
debugStrLn Maybe String
debugMsg
                Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Maybe Float
forall a. a -> Maybe a
Just Float
serverReceiveTime)
        Msg_Heartbeat Float
clientSendTime -> do
          Float
serverReceiveTime <- IO Float
getTime
          Bool
isConnected <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (Maybe PlayerData -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PlayerData -> Bool)
-> (Map clientAddress PlayerData -> Maybe PlayerData)
-> Map clientAddress PlayerData
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. clientAddress -> Map clientAddress PlayerData -> Maybe PlayerData
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup clientAddress
sender (Map clientAddress PlayerData -> Bool)
-> STM (Map clientAddress PlayerData) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isConnected (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ NetMsg input -> clientAddress -> IO ()
sendToClient (Float -> Float -> NetMsg input
forall input. Float -> Float -> NetMsg input
Msg_HeartbeatResponse Float
clientSendTime Float
serverReceiveTime) clientAddress
sender
          Maybe Float -> IO (Maybe Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Maybe Float
forall a. a -> Maybe a
Just Float
serverReceiveTime)
        Msg_Ack Tick
clientMaxAuthTick -> do
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map clientAddress PlayerData)
-> (Map clientAddress PlayerData -> Map clientAddress PlayerData)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map clientAddress PlayerData)
playersTVar ((PlayerData -> Maybe PlayerData)
-> clientAddress
-> Map clientAddress PlayerData
-> Map clientAddress PlayerData
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update (\PlayerData
pd -> PlayerData -> Maybe PlayerData
forall a. a -> Maybe a
Just (PlayerData -> Maybe PlayerData) -> PlayerData -> Maybe PlayerData
forall a b. (a -> b) -> a -> b
$ PlayerData
pd{maxAuthTick :: Tick
maxAuthTick = Tick
clientMaxAuthTick}) clientAddress
sender)
          Float -> Maybe Float
forall a. a -> Maybe a
Just (Float -> Maybe Float) -> IO Float -> IO (Maybe Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Float
getTime
        Msg_SubmitInput [(Tick, input)]
submittedInputs -> do
          [Maybe String]
msgMay <- STM [Maybe String] -> IO [Maybe String]
forall a. STM a -> IO a
atomically (STM [Maybe String] -> IO [Maybe String])
-> STM [Maybe String] -> IO [Maybe String]
forall a b. (a -> b) -> a -> b
$ do
            -- Check that the sender is connected.
            Maybe PlayerData
playerMay <- clientAddress -> Map clientAddress PlayerData -> Maybe PlayerData
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup clientAddress
sender (Map clientAddress PlayerData -> Maybe PlayerData)
-> STM (Map clientAddress PlayerData) -> STM (Maybe PlayerData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
            case Maybe PlayerData
playerMay of
              Maybe PlayerData
Nothing -> [Maybe String] -> STM [Maybe String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Got Msg_SubmitInput from client that is not yet connected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ clientAddress -> String
forall a. Show a => a -> String
show clientAddress
sender]
              Just PlayerData{Float
PlayerId
Tick
lastMesgRcvTime :: Float
maxAuthTick :: Tick
playerId :: PlayerId
lastMesgRcvTime :: PlayerData -> Float
maxAuthTick :: PlayerData -> Tick
playerId :: PlayerData -> PlayerId
..} -> [(Tick, input)]
-> ((Tick, input) -> STM (Maybe String)) -> STM [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Tick, input)]
submittedInputs (((Tick, input) -> STM (Maybe String)) -> STM [Maybe String])
-> ((Tick, input) -> STM (Maybe String)) -> STM [Maybe String]
forall a b. (a -> b) -> a -> b
$ \(Tick
tick, input
input) -> do
                -- Check that the tick time has not already been simulated.
                Tick
nextTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
nextTickTVar
                -- TODO upper bound on allowed tick time.
                if Tick
tick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
< Tick
nextTick
                  then
                    Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> STM (Maybe String))
-> Maybe String -> STM (Maybe String)
forall a b. (a -> b) -> a -> b
$
                      String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
                        String
"Late Msg_Input from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
playerId
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for "
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
tick
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but already simulated up to "
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show (Tick
nextTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1)
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Ignoring."
                  else do
                    IntMap (Map PlayerId input)
inputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
authInputsTVar
                    let inptsAtTick :: Map PlayerId input
inptsAtTick = Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty (IntMap (Map PlayerId input)
inputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick)
                    case Map PlayerId input
inptsAtTick Map PlayerId input -> PlayerId -> Maybe input
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? PlayerId
playerId of
                      Just input
existingInput
                        -- Duplicate message. Silently ignore
                        | input
existingInput input -> input -> Bool
forall a. Eq a => a -> a -> Bool
== input
input -> Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        -- Different input for the same tick!
                        | Bool
otherwise ->
                          Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> STM (Maybe String))
-> Maybe String -> STM (Maybe String)
forall a b. (a -> b) -> a -> b
$
                            String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
                              String
"Received inputs from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlayerId -> String
forall a. Show a => a -> String
show PlayerId
playerId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Tick -> String
forall a. Show a => a -> String
show Tick
tick
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but already have inputs for that time with a DIFFERENT value! Ignoring."
                      -- First time we're hearing of this input. Store it.
                      Maybe input
Nothing -> do
                        TVar (IntMap (Map PlayerId input))
-> IntMap (Map PlayerId input) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (IntMap (Map PlayerId input))
authInputsTVar (IntMap (Map PlayerId input) -> STM ())
-> IntMap (Map PlayerId input) -> STM ()
forall a b. (a -> b) -> a -> b
$
                          Int
-> Map PlayerId input
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert
                            (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
tick)
                            (PlayerId -> input -> Map PlayerId input -> Map PlayerId input
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PlayerId
playerId input
input Map PlayerId input
inptsAtTick)
                            IntMap (Map PlayerId input)
inputs

                        Maybe String -> STM (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
          (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
debugStrLn ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
msgMay)
          Float -> Maybe Float
forall a. a -> Maybe a
Just (Float -> Maybe Float) -> IO Float -> IO (Maybe Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Float
getTime

      -- set receive time for players
      Maybe Float -> (Float -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Float
serverReceiveTimeMay ((Float -> IO ()) -> IO ()) -> (Float -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Float
serverReceiveTime ->
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
          TVar (Map clientAddress PlayerData)
-> (Map clientAddress PlayerData -> Map clientAddress PlayerData)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar
            TVar (Map clientAddress PlayerData)
playersTVar
            ( (PlayerData -> Maybe PlayerData)
-> clientAddress
-> Map clientAddress PlayerData
-> Map clientAddress PlayerData
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update
                (\PlayerData
player -> PlayerData -> Maybe PlayerData
forall a. a -> Maybe a
Just PlayerData
player{lastMesgRcvTime :: Float
lastMesgRcvTime = Float
serverReceiveTime})
                clientAddress
sender
            )

  -- Wait for a connection
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Map clientAddress PlayerData
players <- TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
    Bool -> STM ()
STM.check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map clientAddress PlayerData -> Bool
forall k a. Map k a -> Bool
M.null Map clientAddress PlayerData
players

  String -> IO ()
debugStrLn String
"Client connected. Starting game."

  -- Disconnect players after a timeout
  ThreadId
disconnectTID <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Find next possilbe time to disconnect a player
      Float
oldestMsgRcvTime <- STM Float -> IO Float
forall a. STM a -> IO a
atomically ([Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Float] -> Float)
-> (Map clientAddress PlayerData -> [Float])
-> Map clientAddress PlayerData
-> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerData -> Float) -> [PlayerData] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PlayerData -> Float
lastMesgRcvTime ([PlayerData] -> [Float])
-> (Map clientAddress PlayerData -> [PlayerData])
-> Map clientAddress PlayerData
-> [Float]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map clientAddress PlayerData -> [PlayerData]
forall k a. Map k a -> [a]
M.elems (Map clientAddress PlayerData -> Float)
-> STM (Map clientAddress PlayerData) -> STM Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar)
      let disconnectTime :: Float
disconnectTime = Float
oldestMsgRcvTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ ServerConfig -> Float
scClientTimeout ServerConfig
serverConfig

      -- Wait till the disconnect time (plus a bit to really make sure we pass the threshold)
      Float
t <- IO Float
getTime
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
t Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
disconnectTime) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Int -> IO ()
threadDelay (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (((Float
disconnectTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
t) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.01) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
1000000))

      -- Kick players as needed
      Float
currentTime <- IO Float
getTime
      Map clientAddress PlayerData
kickedPlayers <- STM (Map clientAddress PlayerData)
-> IO (Map clientAddress PlayerData)
forall a. STM a -> IO a
atomically (STM (Map clientAddress PlayerData)
 -> IO (Map clientAddress PlayerData))
-> STM (Map clientAddress PlayerData)
-> IO (Map clientAddress PlayerData)
forall a b. (a -> b) -> a -> b
$ do
        Map clientAddress PlayerData
players <- TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
        let (Map clientAddress PlayerData
retainedPlayers, Map clientAddress PlayerData
kickedPlayers) = (PlayerData -> Bool)
-> Map clientAddress PlayerData
-> (Map clientAddress PlayerData, Map clientAddress PlayerData)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
M.partition (\PlayerData{Float
PlayerId
Tick
lastMesgRcvTime :: Float
maxAuthTick :: Tick
playerId :: PlayerId
lastMesgRcvTime :: PlayerData -> Float
maxAuthTick :: PlayerData -> Tick
playerId :: PlayerData -> PlayerId
..} -> Float
lastMesgRcvTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ ServerConfig -> Float
scClientTimeout ServerConfig
serverConfig Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
currentTime) Map clientAddress PlayerData
players
        TVar (Map clientAddress PlayerData)
-> Map clientAddress PlayerData -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map clientAddress PlayerData)
playersTVar Map clientAddress PlayerData
retainedPlayers
        Map clientAddress PlayerData -> STM (Map clientAddress PlayerData)
forall (m :: * -> *) a. Monad m => a -> m a
return Map clientAddress PlayerData
kickedPlayers
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Map clientAddress PlayerData -> Bool
forall k a. Map k a -> Bool
M.null Map clientAddress PlayerData
kickedPlayers)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
debugStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Disconnect players due to timeout: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Word8] -> String
forall a. Show a => a -> String
show [Word8
pid | PlayerData{playerId :: PlayerData -> PlayerId
playerId = PlayerId Word8
pid} <- Map clientAddress PlayerData -> [PlayerData]
forall k a. Map k a -> [a]
M.elems Map clientAddress PlayerData
kickedPlayers]

  -- Main "simulation" loop
  ThreadId
simTID <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Calculate target tick according to current time
      Float
currTime <- IO Float
getTime
      let targetTick :: Tick
targetTick = Float -> Tick
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Tick) -> Float -> Tick
forall a b. (a -> b) -> a -> b
$ Float
currTime Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
tickTime

      -- Fill auth inputs
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Tick
nextAuthTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
nextTickTVar

        -- Freeze ticks.
        TVar Tick -> Tick -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Tick
nextTickTVar (Tick
targetTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1)

        -- Advance auth inputs up to target tick.
        Map clientAddress PlayerData
knownPlayers <- TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
        IntMap (Map PlayerId input)
authInputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
authInputsTVar
        let nextAuthTickInputs :: Map PlayerId input
nextAuthTickInputs = IntMap (Map PlayerId input)
authInputs IntMap (Map PlayerId input) -> Int -> Map PlayerId input
forall a. IntMap a -> Int -> a
IM.! Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tick
nextAuthTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1)
        TVar (IntMap (Map PlayerId input))
-> IntMap (Map PlayerId input) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (IntMap (Map PlayerId input))
authInputsTVar (IntMap (Map PlayerId input) -> STM ())
-> IntMap (Map PlayerId input) -> STM ()
forall a b. (a -> b) -> a -> b
$
          (IntMap (Map PlayerId input), Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a b. (a, b) -> a
fst ((IntMap (Map PlayerId input), Map PlayerId input)
 -> IntMap (Map PlayerId input))
-> (IntMap (Map PlayerId input), Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a b. (a -> b) -> a -> b
$
            ((IntMap (Map PlayerId input), Map PlayerId input)
 -> Tick -> (IntMap (Map PlayerId input), Map PlayerId input))
-> (IntMap (Map PlayerId input), Map PlayerId input)
-> [Tick]
-> (IntMap (Map PlayerId input), Map PlayerId input)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              ( \(IntMap (Map PlayerId input)
authInputs', Map PlayerId input
prevInputs) Tick
currTick ->
                  let -- Fill inputs for the current tick.
                      currInputsRaw :: Map PlayerId input
currInputsRaw = Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty (Int -> IntMap (Map PlayerId input) -> Maybe (Map PlayerId input)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
currTick) IntMap (Map PlayerId input)
authInputs)
                      currInputs :: Map PlayerId input
currInputs =
                        [(PlayerId, input)] -> Map PlayerId input
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                          [ ( PlayerId
pidInt
                            , input -> Maybe input -> input
forall a. a -> Maybe a -> a
fromMaybe
                                input
input0
                                ( Map PlayerId input
currInputsRaw Map PlayerId input -> PlayerId -> Maybe input
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? PlayerId
pid
                                    Maybe input -> Maybe input -> Maybe input
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Map PlayerId input
prevInputs Map PlayerId input -> PlayerId -> Maybe input
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? PlayerId
pid
                                )
                            )
                          | PlayerId
pid <- PlayerData -> PlayerId
playerId (PlayerData -> PlayerId) -> [PlayerData] -> [PlayerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map clientAddress PlayerData -> [PlayerData]
forall k a. Map k a -> [a]
M.elems Map clientAddress PlayerData
knownPlayers
                          , let pidInt :: PlayerId
pidInt = PlayerId -> PlayerId
coerce PlayerId
pid
                          ]
                   in (Int
-> Map PlayerId input
-> IntMap (Map PlayerId input)
-> IntMap (Map PlayerId input)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
currTick) Map PlayerId input
currInputs IntMap (Map PlayerId input)
authInputs', Map PlayerId input
currInputs)
              )
              (IntMap (Map PlayerId input)
authInputs, Map PlayerId input
nextAuthTickInputs)
              [Tick
nextAuthTick .. Tick
targetTick]

      -- broadcast some auth inputs
      Map clientAddress PlayerData
knownPlayers <- STM (Map clientAddress PlayerData)
-> IO (Map clientAddress PlayerData)
forall a. STM a -> IO a
atomically (STM (Map clientAddress PlayerData)
 -> IO (Map clientAddress PlayerData))
-> STM (Map clientAddress PlayerData)
-> IO (Map clientAddress PlayerData)
forall a b. (a -> b) -> a -> b
$ TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
      (IntMap (Map PlayerId input)
authInputs, Tick
nextAuthTick) <- STM (IntMap (Map PlayerId input), Tick)
-> IO (IntMap (Map PlayerId input), Tick)
forall a. STM a -> IO a
atomically (STM (IntMap (Map PlayerId input), Tick)
 -> IO (IntMap (Map PlayerId input), Tick))
-> STM (IntMap (Map PlayerId input), Tick)
-> IO (IntMap (Map PlayerId input), Tick)
forall a b. (a -> b) -> a -> b
$ do
        IntMap (Map PlayerId input)
authInputs <- TVar (IntMap (Map PlayerId input))
-> STM (IntMap (Map PlayerId input))
forall a. TVar a -> STM a
readTVar TVar (IntMap (Map PlayerId input))
authInputsTVar
        Tick
nextAuthTick <- TVar Tick -> STM Tick
forall a. TVar a -> STM a
readTVar TVar Tick
nextTickTVar
        (IntMap (Map PlayerId input), Tick)
-> STM (IntMap (Map PlayerId input), Tick)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (Map PlayerId input)
authInputs, Tick
nextAuthTick)
      [(clientAddress, PlayerData)]
-> ((clientAddress, PlayerData) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map clientAddress PlayerData -> [(clientAddress, PlayerData)]
forall k a. Map k a -> [(k, a)]
M.assocs Map clientAddress PlayerData
knownPlayers) (((clientAddress, PlayerData) -> IO ()) -> IO ())
-> ((clientAddress, PlayerData) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(clientAddress
sock, PlayerData
playerData) -> do
        let lastAuthTick :: Tick
lastAuthTick = PlayerData -> Tick
maxAuthTick PlayerData
playerData
            (IntMap (Map PlayerId input)
_, Maybe (Map PlayerId input)
_, IntMap (Map PlayerId input)
inputsToSendIntMap') = Int
-> IntMap (Map PlayerId input)
-> (IntMap (Map PlayerId input), Maybe (Map PlayerId input),
    IntMap (Map PlayerId input))
forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IM.splitLookup (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
lastAuthTick) IntMap (Map PlayerId input)
authInputs
            (IntMap (Map PlayerId input)
inputsToSendIntMap, Maybe (Map PlayerId input)
firstHint, IntMap (Map PlayerId input)
_) = Int
-> IntMap (Map PlayerId input)
-> (IntMap (Map PlayerId input), Maybe (Map PlayerId input),
    IntMap (Map PlayerId input))
forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IM.splitLookup (Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
nextAuthTick) IntMap (Map PlayerId input)
inputsToSendIntMap'
            inputsToSend :: [Map PlayerId input]
inputsToSend = Int -> [Map PlayerId input] -> [Map PlayerId input]
forall a. Int -> [a] -> [a]
take Int
maxRequestAuthInputs ([Map PlayerId input] -> [Map PlayerId input])
-> [Map PlayerId input] -> [Map PlayerId input]
forall a b. (a -> b) -> a -> b
$ IntMap (Map PlayerId input) -> [Map PlayerId input]
forall a. IntMap a -> [a]
IM.elems IntMap (Map PlayerId input)
inputsToSendIntMap
            hintsToSendCount :: Int
hintsToSendCount = Int
maxRequestAuthInputs Int -> Int -> Int
forall a. Num a => a -> a -> a
- IntMap (Map PlayerId input) -> Int
forall a. IntMap a -> Int
IM.size IntMap (Map PlayerId input)
inputsToSendIntMap
            hintsToSend :: [Map PlayerId input]
hintsToSend =
              (Maybe (Map PlayerId input) -> Map PlayerId input)
-> [Maybe (Map PlayerId input)] -> [Map PlayerId input]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PlayerId input
-> Maybe (Map PlayerId input) -> Map PlayerId input
forall a. a -> Maybe a -> a
fromMaybe Map PlayerId input
forall k a. Map k a
M.empty) ([Maybe (Map PlayerId input)] -> [Map PlayerId input])
-> [Maybe (Map PlayerId input)] -> [Map PlayerId input]
forall a b. (a -> b) -> a -> b
$
                (Maybe (Map PlayerId input) -> Bool)
-> [Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Maybe (Map PlayerId input) -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)])
-> [Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)]
forall a b. (a -> b) -> a -> b
$
                  Int -> [Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)]
forall a. Int -> [a] -> [a]
take Int
hintsToSendCount ([Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)])
-> [Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)]
forall a b. (a -> b) -> a -> b
$
                    Maybe (Map PlayerId input)
firstHint Maybe (Map PlayerId input)
-> [Maybe (Map PlayerId input)] -> [Maybe (Map PlayerId input)]
forall a. a -> [a] -> [a]
:
                      [ IntMap (Map PlayerId input)
authInputs IntMap (Map PlayerId input) -> Int -> Maybe (Map PlayerId input)
forall a. IntMap a -> Int -> Maybe a
IM.!? Tick -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
hintTick
                      | Tick
hintTick <- [Tick -> Tick
forall a. Enum a => a -> a
succ Tick
nextAuthTick ..]
                      ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Map PlayerId input] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Map PlayerId input]
inputsToSend) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          NetMsg input -> clientAddress -> IO ()
sendToClient
            ( Tick
-> CompactMaps PlayerId input
-> CompactMaps PlayerId input
-> NetMsg input
forall input.
Tick
-> CompactMaps PlayerId input
-> CompactMaps PlayerId input
-> NetMsg input
Msg_AuthInput
                (Tick
lastAuthTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1)
                ([Map PlayerId input] -> CompactMaps PlayerId input
forall key value.
Eq key =>
[Map key value] -> CompactMaps key value
toCompactMaps [Map PlayerId input]
inputsToSend)
                ([Map PlayerId input] -> CompactMaps PlayerId input
forall key value.
Eq key =>
[Map key value] -> CompactMaps key value
toCompactMaps [Map PlayerId input]
hintsToSend)
            )
            clientAddress
sock

      -- Sleep thread till the next tick.
      Float
currTime' <- IO Float
getTime
      let nextTick :: Tick
nextTick = Tick
targetTick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1
          nextTickTime :: Float
nextTickTime = Tick -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tick
nextTick Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
tickTime
          timeTillNextTick :: Float
timeTillNextTick = Float
nextTickTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
currTime'
      Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ Float
1000000 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
timeTillNextTick

  -- Wait till all players quit
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Map clientAddress PlayerData
players <- TVar (Map clientAddress PlayerData)
-> STM (Map clientAddress PlayerData)
forall a. TVar a -> STM a
readTVar TVar (Map clientAddress PlayerData)
playersTVar
    Bool -> STM ()
STM.check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Map clientAddress PlayerData -> Bool
forall k a. Map k a -> Bool
M.null Map clientAddress PlayerData
players

  String -> IO ()
debugStrLn String
"No more clients, Stopping game!"

  (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId
msgProcessingTID, ThreadId
disconnectTID, ThreadId
simTID]

-- | Per player info stored by the server
data PlayerData = PlayerData
  { -- | last tick for which auth inputs were sent from the server
    PlayerData -> PlayerId
playerId :: PlayerId
  , -- | Client's max known auth inputs tick such that there are no missing
    -- ticks before it.
    PlayerData -> Tick
maxAuthTick :: Tick
  , -- | Last server time at which a message was received from this player.
    PlayerData -> Float
lastMesgRcvTime :: Float
  }