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

-- | Rollback and replay based game networking
module Alpaca.NetCode.Internal.Common where

import Control.Concurrent (forkIO, newChan, readChan, threadDelay, writeChan)
import Control.Concurrent.STM as STM
import Control.Monad (forever, when)
import Data.Hashable (Hashable)
import Data.Int (Int64)
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Time.Clock
import Data.Word (Word8)
import Flat
import System.Random (randomRIO)
import Prelude


-- Constants

-- Note above, we don't actually step the simulation here. We leave
-- that all up to the draw function. All we need to do is submit
-- inputs once per tick to the server.

-- | How many missing inputs to request at a time
maxRequestAuthInputs :: Int
maxRequestAuthInputs :: Int
maxRequestAuthInputs = Int
100


-- | TODO I need some proper logging mechanism.
debugStrLn :: String -> IO ()
debugStrLn :: String -> IO ()
debugStrLn String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- This can be thought of as how far the authoritative simulation is behind the
-- clients. Making this large does NOT affect latency. It DOES affect how far
-- back clients might need to roll back their simulation. Too small of a buffer
-- time means inputs will tend to be dropped (not made authoritative) because
-- they arrived a bit late. Too high of a buffer time means clients can
-- experience more pronounced popping/corrections due to large rollback.
--
-- TODO This seems like a bit of a hack. We could instead use a buffer based on
-- out jitter. On the other hand we want to avoid time dilation, so this should
-- not be overly dynamic.
bufferTime :: Duration
bufferTime :: Duration
bufferTime = Duration
0.03 -- seconds


type Time = Float -- seconds


type Duration = Float -- seconds


-- | The game is broken into discrete ticks starting from 0.
newtype Tick = Tick Int64
  deriving stock (Int -> Tick -> ShowS
[Tick] -> ShowS
Tick -> String
(Int -> Tick -> ShowS)
-> (Tick -> String) -> ([Tick] -> ShowS) -> Show Tick
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tick] -> ShowS
$cshowList :: [Tick] -> ShowS
show :: Tick -> String
$cshow :: Tick -> String
showsPrec :: Int -> Tick -> ShowS
$cshowsPrec :: Int -> Tick -> ShowS
Show)
  deriving newtype (Tick -> Tick -> Bool
(Tick -> Tick -> Bool) -> (Tick -> Tick -> Bool) -> Eq Tick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tick -> Tick -> Bool
$c/= :: Tick -> Tick -> Bool
== :: Tick -> Tick -> Bool
$c== :: Tick -> Tick -> Bool
Eq, Eq Tick
Eq Tick
-> (Tick -> Tick -> Ordering)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> Ord Tick
Tick -> Tick -> Bool
Tick -> Tick -> Ordering
Tick -> Tick -> Tick
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 :: Tick -> Tick -> Tick
$cmin :: Tick -> Tick -> Tick
max :: Tick -> Tick -> Tick
$cmax :: Tick -> Tick -> Tick
>= :: Tick -> Tick -> Bool
$c>= :: Tick -> Tick -> Bool
> :: Tick -> Tick -> Bool
$c> :: Tick -> Tick -> Bool
<= :: Tick -> Tick -> Bool
$c<= :: Tick -> Tick -> Bool
< :: Tick -> Tick -> Bool
$c< :: Tick -> Tick -> Bool
compare :: Tick -> Tick -> Ordering
$ccompare :: Tick -> Tick -> Ordering
$cp1Ord :: Eq Tick
Ord, Integer -> Tick
Tick -> Tick
Tick -> Tick -> Tick
(Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick)
-> (Tick -> Tick)
-> (Tick -> Tick)
-> (Integer -> Tick)
-> Num Tick
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Tick
$cfromInteger :: Integer -> Tick
signum :: Tick -> Tick
$csignum :: Tick -> Tick
abs :: Tick -> Tick
$cabs :: Tick -> Tick
negate :: Tick -> Tick
$cnegate :: Tick -> Tick
* :: Tick -> Tick -> Tick
$c* :: Tick -> Tick -> Tick
- :: Tick -> Tick -> Tick
$c- :: Tick -> Tick -> Tick
+ :: Tick -> Tick -> Tick
$c+ :: Tick -> Tick -> Tick
Num, Int -> Tick
Tick -> Int
Tick -> [Tick]
Tick -> Tick
Tick -> Tick -> [Tick]
Tick -> Tick -> Tick -> [Tick]
(Tick -> Tick)
-> (Tick -> Tick)
-> (Int -> Tick)
-> (Tick -> Int)
-> (Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> Tick -> [Tick])
-> Enum Tick
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
$cenumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
enumFromTo :: Tick -> Tick -> [Tick]
$cenumFromTo :: Tick -> Tick -> [Tick]
enumFromThen :: Tick -> Tick -> [Tick]
$cenumFromThen :: Tick -> Tick -> [Tick]
enumFrom :: Tick -> [Tick]
$cenumFrom :: Tick -> [Tick]
fromEnum :: Tick -> Int
$cfromEnum :: Tick -> Int
toEnum :: Int -> Tick
$ctoEnum :: Int -> Tick
pred :: Tick -> Tick
$cpred :: Tick -> Tick
succ :: Tick -> Tick
$csucc :: Tick -> Tick
Enum, Num Tick
Ord Tick
Num Tick -> Ord Tick -> (Tick -> Rational) -> Real Tick
Tick -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Tick -> Rational
$ctoRational :: Tick -> Rational
$cp2Real :: Ord Tick
$cp1Real :: Num Tick
Real, Enum Tick
Real Tick
Real Tick
-> Enum Tick
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> (Tick, Tick))
-> (Tick -> Tick -> (Tick, Tick))
-> (Tick -> Integer)
-> Integral Tick
Tick -> Integer
Tick -> Tick -> (Tick, Tick)
Tick -> Tick -> Tick
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Tick -> Integer
$ctoInteger :: Tick -> Integer
divMod :: Tick -> Tick -> (Tick, Tick)
$cdivMod :: Tick -> Tick -> (Tick, Tick)
quotRem :: Tick -> Tick -> (Tick, Tick)
$cquotRem :: Tick -> Tick -> (Tick, Tick)
mod :: Tick -> Tick -> Tick
$cmod :: Tick -> Tick -> Tick
div :: Tick -> Tick -> Tick
$cdiv :: Tick -> Tick -> Tick
rem :: Tick -> Tick -> Tick
$crem :: Tick -> Tick -> Tick
quot :: Tick -> Tick -> Tick
$cquot :: Tick -> Tick -> Tick
$cp2Integral :: Enum Tick
$cp1Integral :: Real Tick
Integral, Int -> Tick -> Int
Tick -> Int
(Int -> Tick -> Int) -> (Tick -> Int) -> Hashable Tick
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Tick -> Int
$chash :: Tick -> Int
hashWithSalt :: Int -> Tick -> Int
$chashWithSalt :: Int -> Tick -> Int
Hashable, Get Tick
Tick -> Encoding
Tick -> Int -> Int
(Tick -> Encoding) -> Get Tick -> (Tick -> Int -> Int) -> Flat Tick
forall a. (a -> Encoding) -> Get a -> (a -> Int -> Int) -> Flat a
size :: Tick -> Int -> Int
$csize :: Tick -> Int -> Int
decode :: Get Tick
$cdecode :: Get Tick
encode :: Tick -> Encoding
$cencode :: Tick -> Encoding
Flat)


newtype PlayerId = PlayerId {PlayerId -> Word8
unPlayerId :: Word8}
  deriving stock (Int -> PlayerId -> ShowS
[PlayerId] -> ShowS
PlayerId -> String
(Int -> PlayerId -> ShowS)
-> (PlayerId -> String) -> ([PlayerId] -> ShowS) -> Show PlayerId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayerId] -> ShowS
$cshowList :: [PlayerId] -> ShowS
show :: PlayerId -> String
$cshow :: PlayerId -> String
showsPrec :: Int -> PlayerId -> ShowS
$cshowsPrec :: Int -> PlayerId -> ShowS
Show)
  deriving newtype (PlayerId -> PlayerId -> Bool
(PlayerId -> PlayerId -> Bool)
-> (PlayerId -> PlayerId -> Bool) -> Eq PlayerId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayerId -> PlayerId -> Bool
$c/= :: PlayerId -> PlayerId -> Bool
== :: PlayerId -> PlayerId -> Bool
$c== :: PlayerId -> PlayerId -> Bool
Eq, Eq PlayerId
Eq PlayerId
-> (PlayerId -> PlayerId -> Ordering)
-> (PlayerId -> PlayerId -> Bool)
-> (PlayerId -> PlayerId -> Bool)
-> (PlayerId -> PlayerId -> Bool)
-> (PlayerId -> PlayerId -> Bool)
-> (PlayerId -> PlayerId -> PlayerId)
-> (PlayerId -> PlayerId -> PlayerId)
-> Ord PlayerId
PlayerId -> PlayerId -> Bool
PlayerId -> PlayerId -> Ordering
PlayerId -> PlayerId -> PlayerId
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 :: PlayerId -> PlayerId -> PlayerId
$cmin :: PlayerId -> PlayerId -> PlayerId
max :: PlayerId -> PlayerId -> PlayerId
$cmax :: PlayerId -> PlayerId -> PlayerId
>= :: PlayerId -> PlayerId -> Bool
$c>= :: PlayerId -> PlayerId -> Bool
> :: PlayerId -> PlayerId -> Bool
$c> :: PlayerId -> PlayerId -> Bool
<= :: PlayerId -> PlayerId -> Bool
$c<= :: PlayerId -> PlayerId -> Bool
< :: PlayerId -> PlayerId -> Bool
$c< :: PlayerId -> PlayerId -> Bool
compare :: PlayerId -> PlayerId -> Ordering
$ccompare :: PlayerId -> PlayerId -> Ordering
$cp1Ord :: Eq PlayerId
Ord, Integer -> PlayerId
PlayerId -> PlayerId
PlayerId -> PlayerId -> PlayerId
(PlayerId -> PlayerId -> PlayerId)
-> (PlayerId -> PlayerId -> PlayerId)
-> (PlayerId -> PlayerId -> PlayerId)
-> (PlayerId -> PlayerId)
-> (PlayerId -> PlayerId)
-> (PlayerId -> PlayerId)
-> (Integer -> PlayerId)
-> Num PlayerId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> PlayerId
$cfromInteger :: Integer -> PlayerId
signum :: PlayerId -> PlayerId
$csignum :: PlayerId -> PlayerId
abs :: PlayerId -> PlayerId
$cabs :: PlayerId -> PlayerId
negate :: PlayerId -> PlayerId
$cnegate :: PlayerId -> PlayerId
* :: PlayerId -> PlayerId -> PlayerId
$c* :: PlayerId -> PlayerId -> PlayerId
- :: PlayerId -> PlayerId -> PlayerId
$c- :: PlayerId -> PlayerId -> PlayerId
+ :: PlayerId -> PlayerId -> PlayerId
$c+ :: PlayerId -> PlayerId -> PlayerId
Num, Int -> PlayerId -> Int
PlayerId -> Int
(Int -> PlayerId -> Int) -> (PlayerId -> Int) -> Hashable PlayerId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: PlayerId -> Int
$chash :: PlayerId -> Int
hashWithSalt :: Int -> PlayerId -> Int
$chashWithSalt :: Int -> PlayerId -> Int
Hashable)


deriving newtype instance (Flat PlayerId)


-- | Settings for simulating network conditions. Packets in both the send and
-- receive directions are randomly dropped or delayed by `simPing/2` plus some
-- random duration between `-simJitter` and `simJitter`.
data SimNetConditions = SimNetConditions
  { -- | Extra ping (seconds)
    SimNetConditions -> Duration
simPing :: Float
  , -- | Extra jitter (seconds). Should be less than simPing.
    SimNetConditions -> Duration
simJitter :: Float
  , -- | Package loss (0 = no packet loss, 1 = 100% packet loss).
    SimNetConditions -> Duration
simPackageLoss :: Float
  } deriving (Int -> SimNetConditions -> ShowS
[SimNetConditions] -> ShowS
SimNetConditions -> String
(Int -> SimNetConditions -> ShowS)
-> (SimNetConditions -> String)
-> ([SimNetConditions] -> ShowS)
-> Show SimNetConditions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimNetConditions] -> ShowS
$cshowList :: [SimNetConditions] -> ShowS
show :: SimNetConditions -> String
$cshow :: SimNetConditions -> String
showsPrec :: Int -> SimNetConditions -> ShowS
$cshowsPrec :: Int -> SimNetConditions -> ShowS
Show, ReadPrec [SimNetConditions]
ReadPrec SimNetConditions
Int -> ReadS SimNetConditions
ReadS [SimNetConditions]
(Int -> ReadS SimNetConditions)
-> ReadS [SimNetConditions]
-> ReadPrec SimNetConditions
-> ReadPrec [SimNetConditions]
-> Read SimNetConditions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SimNetConditions]
$creadListPrec :: ReadPrec [SimNetConditions]
readPrec :: ReadPrec SimNetConditions
$creadPrec :: ReadPrec SimNetConditions
readList :: ReadS [SimNetConditions]
$creadList :: ReadS [SimNetConditions]
readsPrec :: Int -> ReadS SimNetConditions
$creadsPrec :: Int -> ReadS SimNetConditions
Read, SimNetConditions -> SimNetConditions -> Bool
(SimNetConditions -> SimNetConditions -> Bool)
-> (SimNetConditions -> SimNetConditions -> Bool)
-> Eq SimNetConditions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimNetConditions -> SimNetConditions -> Bool
$c/= :: SimNetConditions -> SimNetConditions -> Bool
== :: SimNetConditions -> SimNetConditions -> Bool
$c== :: SimNetConditions -> SimNetConditions -> Bool
Eq, Eq SimNetConditions
Eq SimNetConditions
-> (SimNetConditions -> SimNetConditions -> Ordering)
-> (SimNetConditions -> SimNetConditions -> Bool)
-> (SimNetConditions -> SimNetConditions -> Bool)
-> (SimNetConditions -> SimNetConditions -> Bool)
-> (SimNetConditions -> SimNetConditions -> Bool)
-> (SimNetConditions -> SimNetConditions -> SimNetConditions)
-> (SimNetConditions -> SimNetConditions -> SimNetConditions)
-> Ord SimNetConditions
SimNetConditions -> SimNetConditions -> Bool
SimNetConditions -> SimNetConditions -> Ordering
SimNetConditions -> SimNetConditions -> SimNetConditions
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 :: SimNetConditions -> SimNetConditions -> SimNetConditions
$cmin :: SimNetConditions -> SimNetConditions -> SimNetConditions
max :: SimNetConditions -> SimNetConditions -> SimNetConditions
$cmax :: SimNetConditions -> SimNetConditions -> SimNetConditions
>= :: SimNetConditions -> SimNetConditions -> Bool
$c>= :: SimNetConditions -> SimNetConditions -> Bool
> :: SimNetConditions -> SimNetConditions -> Bool
$c> :: SimNetConditions -> SimNetConditions -> Bool
<= :: SimNetConditions -> SimNetConditions -> Bool
$c<= :: SimNetConditions -> SimNetConditions -> Bool
< :: SimNetConditions -> SimNetConditions -> Bool
$c< :: SimNetConditions -> SimNetConditions -> Bool
compare :: SimNetConditions -> SimNetConditions -> Ordering
$ccompare :: SimNetConditions -> SimNetConditions -> Ordering
$cp1Ord :: Eq SimNetConditions
Ord)


-- data NetConfig = NetConfig
--   { -- | Add this latency (in seconds) to all input. Players will experience
--     -- this latency even during perfect prediction, but the latency will be
--     -- consistent and reduces artifacts because input messages will be received
--     -- earlier (at least relative to their intended tick). In the extream case,
--     -- if this is set to something higher than ping, there will be no miss
--     -- predictions: all clients will receive inputs before rendering their
--     -- corresponding tick.
--     inputLatency :: Float
--   , -- | Simulate:
--     -- * Ping (seconds)
--     -- * Jitter (seconds)
--     -- * Percentage Package loss (0 = no packet loss, 1 = 100% packet loss)
--     simulatedNetConditions :: Maybe (Float, Float, Float)
--     -- -- | number of times to duplicate unreliable messages (e.g. input messages)
--     -- -- to make them more reliable.
--     -- msgDuplication :: Int64
--   }

simulateNetConditions ::
  -- | Send function
  (msg -> IO ()) ->
  -- | Receive function (blocking)
  (IO msg) ->
  -- | Simulated ping/jitter/packetloss[0-1]
  Maybe SimNetConditions ->
  -- | New send and receive functions.
  IO
    ( msg -> IO ()
    , IO msg
    )
simulateNetConditions :: (msg -> IO ())
-> IO msg -> Maybe SimNetConditions -> IO (msg -> IO (), IO msg)
simulateNetConditions msg -> IO ()
doSendMsg IO msg
doRecvMsg Maybe SimNetConditions
simMay = case Maybe SimNetConditions
simMay of
  Maybe SimNetConditions
Nothing -> (msg -> IO (), IO msg) -> IO (msg -> IO (), IO msg)
forall (m :: * -> *) a. Monad m => a -> m a
return (msg -> IO ()
doSendMsg, IO msg
doRecvMsg)
  Just (SimNetConditions Duration
ping Duration
jitter Duration
loss) -> do
    -- Start a thread that just writes received messages into a chan
    Chan msg
recvChan <- IO (Chan msg)
forall a. IO (Chan a)
newChan
    ThreadId
_recvThreadId <- 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
        msg
msg <- IO msg
doRecvMsg
        Bool
dropPacket <- (Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
<= Duration
loss) (Duration -> Bool) -> IO Duration -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Duration, Duration) -> IO Duration
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Duration
0, Duration
1)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dropPacket) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            Duration
jitterT <- (Duration, Duration) -> IO Duration
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Duration -> Duration
forall a. Num a => a -> a
negate Duration
jitter, Duration
jitter)
            let latency :: Duration
latency = Duration -> Duration -> Duration
forall a. Ord a => a -> a -> a
max Duration
0 ((Duration
ping Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ Duration
2) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
+ Duration
jitterT)
            Int -> IO ()
threadDelay (Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Duration -> Int) -> Duration -> Int
forall a b. (a -> b) -> a -> b
$ Duration
latency Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Duration
1000000)
            Chan msg -> msg -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan msg
recvChan msg
msg
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (msg -> IO (), IO msg) -> IO (msg -> IO (), IO msg)
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( -- Sending a message just starts a thread that delays the send.
        \msg
msg -> do
          Bool
dropPacket <- (Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
< Duration
loss) (Duration -> Bool) -> IO Duration -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Duration, Duration) -> IO Duration
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Duration
0, Duration
1)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
dropPacket) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Duration
jitterT <- (Duration, Duration) -> IO Duration
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Duration -> Duration
forall a. Num a => a -> a
negate Duration
jitter, Duration
jitter)
            let latency :: Duration
latency = Duration -> Duration -> Duration
forall a. Ord a => a -> a -> a
max Duration
0 ((Duration
ping Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ Duration
2) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
+ Duration
jitterT)
            ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
              Int -> IO ()
threadDelay (Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Duration -> Int) -> Duration -> Int
forall a b. (a -> b) -> a -> b
$ Duration
latency Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Duration
1000000)
              msg -> IO ()
doSendMsg msg
msg
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      , Chan msg -> IO msg
forall a. Chan a -> IO a
readChan Chan msg
recvChan
      )


playCommon ::
  Real a =>
  a ->
  ( Float -> -- seconds per tick
    IO Float -> -- get time
    (UTCTime -> STM ()) -> -- Reset timer to 0 at the given time
    IO b
  ) ->
  IO b
playCommon :: a
-> (Duration -> IO Duration -> (UTCTime -> STM ()) -> IO b) -> IO b
playCommon
  a
tickFreq
  Duration -> IO Duration -> (UTCTime -> STM ()) -> IO b
go =
    do
      let tickTime :: Float
          tickTime :: Duration
tickTime = Duration
1 Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ a -> Duration
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
tickFreq

      TVar UTCTime
tick0SysTimTVar <- UTCTime -> IO (TVar UTCTime)
forall a. a -> IO (TVar a)
newTVarIO UTCTime
forall a. HasCallStack => a
undefined

      let getTime :: IO Float
          getTime :: IO Duration
getTime = do
            UTCTime
tick0SysTime <- STM UTCTime -> IO UTCTime
forall a. STM a -> IO a
atomically (STM UTCTime -> IO UTCTime) -> STM UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ TVar UTCTime -> STM UTCTime
forall a. TVar a -> STM a
readTVar TVar UTCTime
tick0SysTimTVar
            UTCTime
timeUTC <- IO UTCTime
getCurrentTime
            Duration -> IO Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> IO Duration) -> Duration -> IO Duration
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Duration
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Duration) -> NominalDiffTime -> Duration
forall a b. (a -> b) -> a -> b
$ UTCTime
timeUTC UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
tick0SysTime

          resetTime :: UTCTime -> STM ()
          resetTime :: UTCTime -> STM ()
resetTime = TVar UTCTime -> UTCTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar UTCTime
tick0SysTimTVar

      UTCTime
currentTime <- IO UTCTime
getCurrentTime
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> STM ()
resetTime UTCTime
currentTime

      Duration -> IO Duration -> (UTCTime -> STM ()) -> IO b
go Duration
tickTime IO Duration
getTime UTCTime -> STM ()
resetTime


data NetMsg input
  = -- Client -> Server
    Msg_Connect
      Float -- Client's local time (used for initial clock sync).
  | -- Server -> Client
    Msg_Connected PlayerId
  | -- | Client -> Server: Regularly sent. Used for clock sync and to acknowledge receiving auth ticks up to a given point.
    Msg_Heartbeat
      Float -- Client's local time (used for clock sync).
  | -- Client -> server
    Msg_Ack
      Tick -- Client's max known auth inputs tick such that there are no missing ticks before it.
  | -- | Server -> Client: Sent in response to Msg_Connect. This indicates the
    -- clients PlayerId
    Msg_HeartbeatResponse
      -- Clock time on the server at Tick 0 is alwyas just 0.
      Float -- Clock time on the client when the connect message was sent.
      Float -- Clock time on the server when the connect message was received.
  | -- | Server -> Client: complete authoritative inputs for a run of ticks
    Msg_AuthInput
      Tick -- Start tick (inclusive)
      (CompactMaps PlayerId input) -- auth ticks starting at the given tick
      (CompactMaps PlayerId input) -- non-auth ticks (hints) starting after the auth ticks
  | -- | A non-authoritative hint for some input.
    Msg_HintInput Tick PlayerId input
  | Msg_SubmitInput [(Tick, input)]
  deriving stock (Int -> NetMsg input -> ShowS
[NetMsg input] -> ShowS
NetMsg input -> String
(Int -> NetMsg input -> ShowS)
-> (NetMsg input -> String)
-> ([NetMsg input] -> ShowS)
-> Show (NetMsg input)
forall input. Show input => Int -> NetMsg input -> ShowS
forall input. Show input => [NetMsg input] -> ShowS
forall input. Show input => NetMsg input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NetMsg input] -> ShowS
$cshowList :: forall input. Show input => [NetMsg input] -> ShowS
show :: NetMsg input -> String
$cshow :: forall input. Show input => NetMsg input -> String
showsPrec :: Int -> NetMsg input -> ShowS
$cshowsPrec :: forall input. Show input => Int -> NetMsg input -> ShowS
Show, (forall x. NetMsg input -> Rep (NetMsg input) x)
-> (forall x. Rep (NetMsg input) x -> NetMsg input)
-> Generic (NetMsg input)
forall x. Rep (NetMsg input) x -> NetMsg input
forall x. NetMsg input -> Rep (NetMsg input) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall input x. Rep (NetMsg input) x -> NetMsg input
forall input x. NetMsg input -> Rep (NetMsg input) x
$cto :: forall input x. Rep (NetMsg input) x -> NetMsg input
$cfrom :: forall input x. NetMsg input -> Rep (NetMsg input) x
Generic)


deriving instance Flat input => Flat (NetMsg input)


newtype CompactMaps key value = CompactMaps [([key], [[value]])]
  deriving stock ((forall x. CompactMaps key value -> Rep (CompactMaps key value) x)
-> (forall x.
    Rep (CompactMaps key value) x -> CompactMaps key value)
-> Generic (CompactMaps key value)
forall x. Rep (CompactMaps key value) x -> CompactMaps key value
forall x. CompactMaps key value -> Rep (CompactMaps key value) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall key value x.
Rep (CompactMaps key value) x -> CompactMaps key value
forall key value x.
CompactMaps key value -> Rep (CompactMaps key value) x
$cto :: forall key value x.
Rep (CompactMaps key value) x -> CompactMaps key value
$cfrom :: forall key value x.
CompactMaps key value -> Rep (CompactMaps key value) x
Generic, Int -> CompactMaps key value -> ShowS
[CompactMaps key value] -> ShowS
CompactMaps key value -> String
(Int -> CompactMaps key value -> ShowS)
-> (CompactMaps key value -> String)
-> ([CompactMaps key value] -> ShowS)
-> Show (CompactMaps key value)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall key value.
(Show key, Show value) =>
Int -> CompactMaps key value -> ShowS
forall key value.
(Show key, Show value) =>
[CompactMaps key value] -> ShowS
forall key value.
(Show key, Show value) =>
CompactMaps key value -> String
showList :: [CompactMaps key value] -> ShowS
$cshowList :: forall key value.
(Show key, Show value) =>
[CompactMaps key value] -> ShowS
show :: CompactMaps key value -> String
$cshow :: forall key value.
(Show key, Show value) =>
CompactMaps key value -> String
showsPrec :: Int -> CompactMaps key value -> ShowS
$cshowsPrec :: forall key value.
(Show key, Show value) =>
Int -> CompactMaps key value -> ShowS
Show)


deriving newtype instance (Flat key, Flat value) => Flat (CompactMaps key value)


-- | Convert a list of maps to a datastructure that is more compact when
-- serialized by flat. This is more compact assuming that many subsequent maps
-- have the same key set.
{-# SPECIALIZE toCompactMaps :: [Map PlayerId input] -> CompactMaps PlayerId input #-}
toCompactMaps :: Eq key => [Map key value] -> CompactMaps key value
toCompactMaps :: [Map key value] -> CompactMaps key value
toCompactMaps [Map key value]
maps =
  [([key], [[value]])] -> CompactMaps key value
forall key value. [([key], [[value]])] -> CompactMaps key value
CompactMaps
    [ ([key]
runKeys, Map key value -> [value]
forall k a. Map k a -> [a]
M.elems (Map key value -> [value]) -> [Map key value] -> [[value]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Map key value]
run)
    | [Map key value]
run <- (Map key value -> Map key value -> Bool)
-> [Map key value] -> [[Map key value]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\Map key value
a Map key value
b -> Map key value -> Set key
forall k a. Map k a -> Set k
M.keysSet Map key value
a Set key -> Set key -> Bool
forall a. Eq a => a -> a -> Bool
== Map key value -> Set key
forall k a. Map k a -> Set k
M.keysSet Map key value
b) [Map key value]
maps
    , let runKeys :: [key]
runKeys = Map key value -> [key]
forall k a. Map k a -> [k]
M.keys ([Map key value] -> Map key value
forall a. [a] -> a
head [Map key value]
run)
    ]


-- | Inverse of toCompactMaps
{-# SPECIALIZE fromCompactMaps :: CompactMaps PlayerId input -> [Map PlayerId input] #-}
fromCompactMaps :: Eq key => CompactMaps key value -> [Map key value]
fromCompactMaps :: CompactMaps key value -> [Map key value]
fromCompactMaps (CompactMaps [([key], [[value]])]
runs) =
  [ [(key, value)] -> Map key value
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList ([key] -> [value] -> [(key, value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [key]
keys [value]
values)
  | ([key]
keys, [[value]]
valuess) <- [([key], [[value]])]
runs
  , [value]
values <- [[value]]
valuess
  ]