├── .gitignore ├── Setup.hs ├── CHANGELOG.md ├── .github └── workflows │ └── haskell.yml ├── README.md ├── alpaca-netcode.cabal ├── src └── Alpaca │ ├── NetCode.hs │ └── NetCode │ ├── Advanced.hs │ └── Internal │ ├── ClockSync.hs │ ├── Common.hs │ ├── Server.hs │ └── Client.hs ├── test └── Test.hs └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | .stack-work 3 | .vscode/ -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for alpaca-netcode 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: actions/setup-haskell@v1 17 | with: 18 | ghc-version: '8.10.3' 19 | cabal-version: '3.2' 20 | 21 | - name: Cache 22 | uses: actions/cache@v1 23 | env: 24 | cache-name: cache-cabal 25 | with: 26 | path: ~/.cabal 27 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 28 | restore-keys: | 29 | ${{ runner.os }}-build-${{ env.cache-name }}- 30 | ${{ runner.os }}-build- 31 | ${{ runner.os }}- 32 | 33 | - name: Install dependencies 34 | run: | 35 | cabal update 36 | cabal build --only-dependencies --enable-tests --enable-benchmarks 37 | - name: Build 38 | run: cabal build --enable-tests --enable-benchmarks all 39 | - name: Run tests 40 | run: cabal run test -- -p "!/[NOCI]/" 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Alpaca NetCode 2 | 3 | A rollback/replay client-server system for realtime multiplayer games. The API 4 | only requires you to express your game as a pure, deterministic function. 5 | 6 | ## Advantages 7 | 8 | * Simple code. Your game logic contains no NetCode. 9 | * Low bandwidth. Only inputs are shared. 10 | * Zero latency. Player's own inputs affect their game immediatly. 11 | * UDP based. Unordered and using redundancy to mitigate packet loss. 12 | * Lightweight server. The server does not run the game logic, it only relays and tracks user inputs. 13 | * Cheating. Only inputs are shared which eliminates a whole class state manipulation cheats. 14 | 15 | ## Disadvantages 16 | 17 | * Increased CPU usage. Rollback/replay means that clients must run the game step function multiple times per frame. 18 | * Not suitable for large numbers of players. Tens of players is likey reasonable. 19 | 20 | ## Disclaimer 21 | 22 | This is an initial release with minimal functionality and still very 23 | experimental. Use at your own risk. 24 | 25 | ## Contributing 26 | 27 | PRs, feadback, and feature requests welcome. See the [Roadmap 28 | issue](https://github.com/DavidEichmann/alpaca-netcode/issues/1) for ideas. Or 29 | ping @DavidE on the [Haskell GameDev](https://discord.gg/T7kJSq8C) discord 30 | server. 31 | -------------------------------------------------------------------------------- /alpaca-netcode.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: alpaca-netcode 3 | version: 0.1.0.0 4 | synopsis: Rollback/replay NetCode for realtime, deterministic, multiplayer games. 5 | description: 6 | A rollback/replay client-server system for realtime multiplayer games. The API 7 | only requires you to express your game as a pure, deterministic function. 8 | . 9 | See "Alpaca.NetCode" to get started. 10 | . 11 | === Advantages 12 | * Simple code. Your game logic contains no NetCode. 13 | * Low bandwidth. Only inputs are shared. 14 | * Zero latency. Player's own inputs affect their game immediatly. 15 | * UDP based. Unordered and using redundancy to mitigate packet loss. 16 | * Lightweight server. The server does not run the game logic, it only relays and tracks user inputs. 17 | * Cheating. Only inputs are shared which eliminates a whole class state manipulation cheats. 18 | . 19 | === Disadvantages 20 | * Increased CPU usage. Rollback/replay means that clients must run the game step function multiple times per frame. 21 | * Not suitable for large numbers of players. Tens of players is likey reasonable. 22 | . 23 | === Disclaimer 24 | This is an initial release with minimal functionality and still very 25 | experimental. Use at your own risk. 26 | 27 | -- bug-reports: 28 | license: Apache-2.0 29 | license-file: LICENSE 30 | author: David Eichmann 31 | maintainer: davide@well-typed.com 32 | copyright: 2021 David Eichmann 33 | category: Network, Game Engine 34 | build-type: Simple 35 | extra-source-files: CHANGELOG.md 36 | 37 | source-repository head 38 | type: git 39 | location: https://github.com/DavidEichmann/alpaca-netcode 40 | 41 | library 42 | other-modules: 43 | Alpaca.NetCode.Internal.Client 44 | , Alpaca.NetCode.Internal.ClockSync 45 | , Alpaca.NetCode.Internal.Common 46 | , Alpaca.NetCode.Internal.Server 47 | exposed-modules: 48 | Alpaca.NetCode 49 | , Alpaca.NetCode.Advanced 50 | build-depends: base >= 4.9 && < 4.16 51 | , bytestring 52 | , containers 53 | , flat 54 | , hashable 55 | , network >= 3.1 && < 3.2 56 | , network-run 57 | , random 58 | , stm 59 | , time 60 | 61 | hs-source-dirs: src 62 | ghc-options: -Wall 63 | default-language: Haskell2010 64 | 65 | test-suite test 66 | Type: exitcode-stdio-1.0 67 | hs-source-dirs: test 68 | Main-is: Test.hs 69 | Build-depends: base >= 4.9 && < 4.16 70 | , alpaca-netcode 71 | , containers 72 | , random 73 | , tasty 74 | , tasty-hunit 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /src/Alpaca/NetCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RecursiveDo #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TupleSections #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# LANGUAGE TypeFamilies #-} 21 | {-# OPTIONS_HADDOCK not-home #-} 22 | 23 | -- | This module should be all you need to get started writing multiplayer 24 | -- games. See "Alpaca.NetCode.Advanced" for more advanced usage. 25 | module Alpaca.NetCode ( 26 | runServer, 27 | runClient, 28 | Client, 29 | clientPlayerId, 30 | clientSample, 31 | clientSetInput, 32 | clientStop, 33 | 34 | -- ** Types 35 | Tick (..), 36 | PlayerId (..), 37 | HostName, 38 | ServiceName, 39 | ) where 40 | 41 | import Alpaca.NetCode.Advanced 42 | import qualified Data.Map as M 43 | import Flat ( 44 | Flat, 45 | ) 46 | import Prelude 47 | 48 | 49 | -- | Start a client. This blocks until the initial handshake with the server is 50 | -- finished. You must call 'clientSetInput' on the returned client to submit new 51 | -- inputs. 52 | -- 53 | -- Think of @world@ as shared state between all clients. Alpaca NetCode takes 54 | -- care of synchronizing and predicting the @world@ state across all clients. 55 | -- Additionally, clock synchronization is done with the server and the "current" 56 | -- tick is decided for you when sampling with `clientSample`. 57 | -- 58 | -- Typical usage looks like this: 59 | -- 60 | -- @ 61 | -- main :: IO () 62 | -- main = do 63 | -- myClient <- runClient "localhost" "8111" 30 myInput0 myWorld0 worldStep 64 | -- let myPlayerId = clientPlayerId myClient 65 | -- 66 | -- mainGameLoop $ do 67 | -- myInput <- pollInput -- Poll inputs from some other library 68 | -- clientSetInput myClient -- Push inputs to Alpaca NetCode 69 | -- world <- clientSample -- Sample the current (predicted) world 70 | -- renderWorld myPlayerId world -- Render the world 71 | -- 72 | -- -- You're free to do IO and maintain state local to the client. 73 | -- 74 | -- return (gameIsOver world) -- Return True to keep looping 75 | -- 76 | -- clientStop myClient 77 | -- 78 | -- -- Given 79 | -- data World = World { .. } 80 | -- data Input = Input { .. } deriving (Generic, Eq, Flat) 81 | -- myWorld0 :: World 82 | -- gameIsOver :: World -> Bool 83 | -- myInput0 :: Input 84 | -- worldStep :: Map PlayerId Input -> Tick -> World -> World 85 | -- renderWorld :: PlayerId -> World -> IO () 86 | -- pollInput :: IO Input 87 | -- mainGameLoop :: IO Bool -> IO () 88 | -- @ 89 | runClient :: 90 | forall world input. 91 | Flat input => 92 | -- | The server's host name or IP address e.g. @"localhost"@. 93 | HostName -> 94 | -- | The server's port number e.g. @"8111"@. 95 | ServiceName -> 96 | -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same 97 | -- across all clients and the server. Packet rate and hence network bandwidth 98 | -- will scale linearly with the tick rate. 99 | Int -> 100 | -- | Initial input for new players. Must be the same across all clients and 101 | -- the server. 102 | -- 103 | -- Note that the client and server do input "prediction" by assuming @input@s 104 | -- do not change. It is important to design your @input@ type accordingly. For 105 | -- example, Do NOT store a @Bool@ indicating that a button has been clicked. 106 | -- Instead, store a @Bool@ indicating if that button is currently held down. 107 | -- Then, store enough information in the @world@ state to identify a click. 108 | input -> 109 | -- | Initial world state. Must be the same across all clients. 110 | world -> 111 | -- | A deterministic stepping function (for a single tick). In practice you 112 | -- can choose to use whatever monad stack within as long as you (un)wrap into 113 | -- a pure function e.g. you can use `ST` as long as you wrap it in `runST`. 114 | -- Must be the same across all clients and the server. Takes: 115 | -- 116 | -- * a map from PlayerId to current input. You can use the key set as the set 117 | -- of all connected players. 118 | -- * current game tick. 119 | -- * previous tick's world state. 120 | -- 121 | -- It is important that this is deterministic else clients' states will 122 | -- diverge. Beware of floating point non-determinism! 123 | ( M.Map PlayerId input -> 124 | Tick -> 125 | world -> 126 | world 127 | ) -> 128 | IO (Client world input) 129 | runClient 130 | serverHostName 131 | serverPort 132 | tickRate 133 | input0 134 | world0 135 | stepOneTick = 136 | runClientWith 137 | serverHostName 138 | serverPort 139 | Nothing 140 | (defaultClientConfig tickRate) 141 | input0 142 | world0 143 | stepOneTick 144 | 145 | 146 | -- | Run a server for a single game. This will block until the game ends, 147 | -- specifically when all players have disconnected. 148 | runServer :: 149 | forall input. 150 | (Eq input, Flat input) => 151 | -- | The server's port number e.g. @"8111"@. 152 | ServiceName -> 153 | -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same 154 | -- across all clients and the server. Packet rate and hence network bandwidth 155 | -- will scale linearly with the tick rate. 156 | Int -> 157 | -- | Initial input for new players. Must be the same across all clients and 158 | -- the server. 159 | input -> 160 | IO () 161 | runServer 162 | serverPort 163 | tickRate 164 | input0 = 165 | runServerWith 166 | serverPort 167 | Nothing 168 | (defaultServerConfig tickRate) 169 | input0 -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | import Test.Tasty 4 | import Test.Tasty.HUnit 5 | import Control.Concurrent 6 | import Control.Monad (forever, when) 7 | import Data.Bits 8 | import Data.Map (Map) 9 | import Data.Maybe (isNothing) 10 | import qualified Data.Map as M 11 | import Data.Int (Int64) 12 | import System.Random (randomIO) 13 | import System.Timeout (timeout) 14 | import Alpaca.NetCode 15 | import Alpaca.NetCode.Advanced 16 | import Data.Maybe (fromMaybe) 17 | import Data.List (foldl') 18 | 19 | main :: IO () 20 | main = defaultMain $ testGroup "alpaca-netcode" $ let 21 | tickRate = 1000 22 | tickRate32 = fromIntegral 1000 23 | 24 | initialInput :: Int64 25 | initialInput = 123456789 26 | 27 | inputLatency :: Float 28 | inputLatency = 0.1 29 | 30 | -- Step of the world does a simple hashes all the inputs. 31 | stepWorld :: Map PlayerId Int64 -> Tick -> (Int64, Int64) -> (Int64, Int64) 32 | stepWorld playerInputs (Tick t) (_numPlayersOld, hash) = 33 | ( fromIntegral $ M.size playerInputs 34 | , foldl' 35 | (\hash' x -> (shiftL hash' 1) `xor` x) 36 | (shiftL hash 1 `xor` t) 37 | (concat [[fromIntegral i, j] | (PlayerId i, j) <- M.toList playerInputs]) 38 | ) 39 | 40 | -- (number of players on this tick, hash over past states/inputs) 41 | initialWorld :: (Int64, Int64) 42 | initialWorld = (0, 12345654321) 43 | 44 | simulateClient :: (Int64 -> IO ()) -> IO ThreadId 45 | simulateClient setInput = forkIO $ forever $ do 46 | threadDelay (1000000 `div` tickRate) 47 | setInput =<< randomIO 48 | 49 | test :: 50 | ( Maybe SimNetConditions 51 | -> ServerConfig 52 | -> Int64 53 | -> IO () 54 | ) 55 | -> (Maybe SimNetConditions 56 | -> ClientConfig 57 | -> Int64 58 | -> (Int64, Int64) 59 | -> (Map PlayerId Int64 -> Tick -> (Int64, Int64) -> (Int64, Int64)) -> IO (Client (Int64, Int64) Int64) 60 | ) 61 | -> (Maybe SimNetConditions 62 | -> ClientConfig 63 | -> Int64 64 | -> (Int64, Int64) 65 | -> (Map PlayerId Int64 -> Tick -> (Int64, Int64) -> (Int64, Int64)) -> IO (Client (Int64, Int64) Int64) 66 | ) 67 | -> IO () 68 | test runServerWith' runClient0With' runClient1With' = do 69 | x <- timeout (15 * 1000000) $ do 70 | -- Run a server 71 | tidServer <- forkIO $ runServerWith' 72 | Nothing 73 | (defaultServerConfig tickRate32) 74 | initialInput 75 | 76 | -- A client with Perfect network conditions 77 | client0 <- runClient0With' 78 | Nothing 79 | (defaultClientConfig tickRate32) 80 | initialInput 81 | initialWorld 82 | stepWorld 83 | tid0 <- simulateClient (clientSetInput client0) 84 | 85 | -- A client with very poor network conditions 86 | client1 <- runClient1With' 87 | (Just (SimNetConditions 0.2 0.1 0.5)) 88 | (defaultClientConfig tickRate32) 89 | initialInput 90 | initialWorld 91 | stepWorld 92 | tid1 <- simulateClient (clientSetInput client1) 93 | 94 | -- Let the game play for a bit 95 | threadDelay (4 * 1000000) 96 | 97 | -- Collect auth worlds from both clients 98 | let n = 2000 99 | auths0 <- take n . fst <$> clientSample' client0 100 | auths1 <- take n . fst <$> clientSample' client1 101 | 102 | length auths0 >= n @? "Expected at least " ++ show n ++ " auth worlds but client 0 got " ++ show (length auths0) 103 | length auths1 >= n @? "Expected at least " ++ show n ++ " auth worlds but client 1 got " ++ show (length auths1) 104 | 105 | (auths0 == auths1) @? "Auth worlds do not match between clients" 106 | 107 | let k = 100 108 | length (filter ((>0) . fst) auths0) > k @? "Expected at least " ++ show k ++ " tick with more that 0 players" 109 | 110 | killThread tidServer 111 | clientStop client0 112 | killThread tid0 113 | clientStop client1 114 | killThread tid1 115 | 116 | return () 117 | when (isNothing x) (assertFailure "Timeout!") 118 | in 119 | [ testCase "Core" $ do 120 | -- Use `Chan` to communicate 121 | toServer <- newChan 122 | toClient0 <- newChan 123 | toClient1 <- newChan 124 | 125 | test 126 | (runServerWith' 127 | (\msg (client :: Int64) -> case client of 128 | 0 -> writeChan toClient0 msg 129 | 1 -> writeChan toClient1 msg 130 | _ -> error $ "Test error! unknown client: " ++ show client 131 | ) 132 | (readChan toServer) 133 | ) 134 | ( runClientWith' 135 | (\msg -> writeChan toServer (msg, 0)) 136 | (readChan toClient0) 137 | ) 138 | (runClientWith' 139 | (\msg -> writeChan toServer (msg, 1)) 140 | (readChan toClient1) 141 | ) 142 | , testCase "UDP [NOCI]" $ do 143 | let port = "8888" 144 | test 145 | (runServerWith port) 146 | (runClientWith "localhost" port) 147 | (runClientWith "localhost" port) 148 | , testCase "clientStop" $ do 149 | toServer <- newChan 150 | toClient <- newChan 151 | 152 | -- Run a server 153 | tidServer <- forkIO $ runServerWith' 154 | (\msg 0 -> writeChan toClient msg) 155 | (readChan toServer) 156 | Nothing 157 | (defaultServerConfig tickRate32) 158 | initialInput 159 | 160 | -- A client with Perfect network conditions 161 | client <- runClientWith' 162 | (\msg -> writeChan toServer (msg, 0)) 163 | (readChan toClient) 164 | Nothing 165 | (defaultClientConfig tickRate32) 166 | initialInput 167 | initialWorld 168 | stepWorld 169 | tidClient <- simulateClient (clientSetInput client) 170 | 171 | threadDelay (2 * 1000000) 172 | clientStop client 173 | w <- clientSample client 174 | threadDelay (1 * 1000000) 175 | (authWs', w') <- clientSample' client 176 | assertEqual 177 | "Sample after clientStop should return the last sampled world" 178 | w w' 179 | assertEqual 180 | "Sample after clientStop should return no new auth worlds" 181 | authWs' [] 182 | 183 | threadDelay (1 * 1000000) 184 | clientStop client 185 | (authWs'', w'') <- clientSample' client 186 | assertEqual 187 | "Sample after SECOND clientStop should return the last sampled world" 188 | w w'' 189 | assertEqual 190 | "Sample after clientStop should return no new auth worlds" 191 | authWs'' [] 192 | 193 | killThread tidServer 194 | killThread tidClient 195 | 196 | ] -------------------------------------------------------------------------------- /src/Alpaca/NetCode/Advanced.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RecursiveDo #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TupleSections #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# LANGUAGE TypeFamilies #-} 21 | 22 | -- | Rollback and replay based game networking 23 | module Alpaca.NetCode.Advanced ( 24 | -- * Server 25 | runServerWith, 26 | module Alpaca.NetCode.Internal.Server, 27 | 28 | -- * Client 29 | runClientWith, 30 | module Alpaca.NetCode.Internal.Client, 31 | 32 | -- * Common Types 33 | SimNetConditions (..), 34 | Tick (..), 35 | PlayerId (..), 36 | NetMsg, 37 | HostName, 38 | ServiceName, 39 | ) where 40 | 41 | import Alpaca.NetCode.Internal.Client 42 | import Alpaca.NetCode.Internal.Common 43 | import Alpaca.NetCode.Internal.Server 44 | import Control.Concurrent ( 45 | Chan, 46 | forkIO, 47 | newChan, 48 | readChan, 49 | writeChan, 50 | ) 51 | import qualified Control.Exception as E 52 | import Control.Monad 53 | import qualified Data.ByteString as BS 54 | import qualified Data.ByteString.Lazy as BSL 55 | import qualified Data.Map as M 56 | import Flat ( 57 | DecodeException (BadEncoding), 58 | Flat, 59 | flat, 60 | unflat, 61 | ) 62 | import Network.Run.UDP (runUDPServer) 63 | import Network.Socket ( 64 | AddrInfo ( 65 | addrAddress, 66 | addrFamily, 67 | addrFlags, 68 | addrProtocol, 69 | addrSocketType 70 | ), 71 | AddrInfoFlag (AI_PASSIVE), 72 | HostName, 73 | ServiceName, 74 | SockAddr, 75 | Socket, 76 | SocketType (Datagram), 77 | close, 78 | connect, 79 | defaultHints, 80 | getAddrInfo, 81 | socket, 82 | withSocketsDo, 83 | ) 84 | import qualified Network.Socket.ByteString as NBS 85 | import Prelude 86 | 87 | 88 | -- | Start a client. This blocks until the initial handshake with the server is 89 | -- finished. 90 | runClientWith :: 91 | forall world input. 92 | Flat input => 93 | -- | The server's host name or IP address e.g. @"localhost"@. 94 | HostName -> 95 | -- | The server's port number e.g. @"8111"@. 96 | ServiceName -> 97 | -- | Optional simulation of network conditions. In production this should be 98 | -- `Nothing`. May differ between clients. 99 | Maybe SimNetConditions -> 100 | -- | The 'defaultClientConfig' works well for most cases. 101 | ClientConfig -> 102 | -- | Initial input for new players. Must be the same across all clients and 103 | -- the server. See 'Alpaca.NetCode.runClient'. 104 | input -> 105 | -- | Initial world state. Must be the same across all clients. 106 | world -> 107 | -- | A deterministic stepping function (for a single tick). Must be the same 108 | -- across all clients and the server. See 'Alpaca.NetCode.runClient'. 109 | ( M.Map PlayerId input -> 110 | Tick -> 111 | world -> 112 | world 113 | ) -> 114 | IO (Client world input) 115 | runClientWith 116 | serverHostName 117 | serverPort 118 | simNetConditionsMay 119 | clientConfig 120 | input0 121 | world0 122 | stepOneTick = do 123 | sendChan <- newChan 124 | recvChan <- newChan 125 | 126 | -- UDP 127 | _ <- forkIO $ do 128 | runUDPClient' serverHostName serverPort $ \sock server -> do 129 | _ <- 130 | forkIO $ 131 | writeDatagramContentsAsNetMsg (Just server) fst recvChan sock 132 | forever $ do 133 | msg <- readChan sendChan 134 | NBS.sendAllTo sock (flat msg) server 135 | 136 | runClientWith' 137 | (writeChan sendChan) 138 | (readChan recvChan) 139 | simNetConditionsMay 140 | clientConfig 141 | input0 142 | world0 143 | stepOneTick 144 | where 145 | -- 146 | -- Coppied from network-run 147 | -- 148 | 149 | runUDPClient' :: 150 | HostName -> ServiceName -> (Socket -> SockAddr -> IO a) -> IO a 151 | runUDPClient' host port client = withSocketsDo $ do 152 | addr <- resolve Datagram (Just host) port False 153 | let sockAddr = addrAddress addr 154 | E.bracket (openSocket addr) close $ \sock -> client sock sockAddr 155 | 156 | resolve :: SocketType -> Maybe HostName -> ServiceName -> Bool -> IO AddrInfo 157 | resolve socketType mhost port passive = 158 | head 159 | <$> getAddrInfo (Just hints) mhost (Just port) 160 | where 161 | hints = 162 | defaultHints 163 | { addrSocketType = socketType 164 | , addrFlags = if passive then [AI_PASSIVE] else [] 165 | } 166 | 167 | openSocket :: AddrInfo -> IO Socket 168 | openSocket addr = do 169 | sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 170 | connect sock (addrAddress addr) 171 | return sock 172 | 173 | 174 | -- | Run a server for a single game. This will block until the game ends, 175 | -- specifically when all players have disconnected. 176 | runServerWith :: 177 | forall input. 178 | (Eq input, Flat input) => 179 | -- | The server's port number e.g. @"8111"@. 180 | ServiceName -> 181 | -- | Optional simulation of network conditions. In production this should be 182 | -- `Nothing`. 183 | Maybe SimNetConditions -> 184 | -- | The 'defaultServerConfig' works well for most cases. 185 | ServerConfig -> 186 | -- | Initial input for new players. Must be the same across all clients and 187 | -- the server. 188 | input -> 189 | IO () 190 | runServerWith serverPort tickRate netConfig input0 = do 191 | sendChan <- newChan 192 | recvChan <- newChan 193 | 194 | -- UDP 195 | _ <- forkIO $ do 196 | runUDPServer Nothing serverPort $ \sock -> do 197 | _ <- forkIO $ writeDatagramContentsAsNetMsg Nothing id recvChan sock 198 | forever $ do 199 | (msg, addr) <- readChan sendChan 200 | NBS.sendAllTo sock (flat msg) addr 201 | 202 | runServerWith' 203 | (curry (writeChan sendChan)) 204 | (readChan recvChan) 205 | tickRate 206 | netConfig 207 | input0 208 | 209 | 210 | -- Forever decode messages from the input socket using the given decoding 211 | -- function and writing it to the given chan. Loops forever. 212 | writeDatagramContentsAsNetMsg :: 213 | forall input a. 214 | (Flat input) => 215 | -- | Just the sender if alwalys receiving from the same address (used in the client case where we only receive from the server) 216 | (Maybe SockAddr) -> 217 | -- | Decode the messages 218 | ((NetMsg input, SockAddr) -> a) -> 219 | -- | Write decoded msgs to this chan 220 | Chan a -> 221 | -- | Read from this socket 222 | Socket -> 223 | IO () 224 | writeDatagramContentsAsNetMsg constSenderMay f chan sock = go 225 | where 226 | go = do 227 | let maxBytes = 4096 228 | (bs, sender) <- case constSenderMay of 229 | Nothing -> NBS.recvFrom sock maxBytes 230 | Just s -> (,s) <$> NBS.recv sock maxBytes 231 | if BS.length bs == maxBytes 232 | then 233 | error $ 234 | "TODO support packets bigger than " 235 | ++ show maxBytes 236 | ++ " bytes." 237 | else 238 | if BS.length bs == 0 239 | then debugStrLn "Received 0 bytes from socket. Stopping." 240 | else do 241 | case unflat @(NetMsg input) (BSL.fromStrict bs) of 242 | Left err -> do 243 | debugStrLn $ 244 | "Error decoding message: " ++ case err of 245 | BadEncoding env errStr -> 246 | "BadEncoding " ++ show env ++ "\n" ++ errStr 247 | _ -> show err 248 | Right msg -> writeChan chan (f (msg, sender)) 249 | go 250 | -------------------------------------------------------------------------------- /src/Alpaca/NetCode/Internal/ClockSync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RecursiveDo #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TupleSections #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# LANGUAGE TypeFamilies #-} 21 | 22 | -- | Rollback and replay based game networking 23 | module Alpaca.NetCode.Internal.ClockSync where 24 | 25 | import Alpaca.NetCode.Internal.Common 26 | import Control.Concurrent.STM 27 | import Data.Int (Int64) 28 | import Data.Maybe (fromMaybe) 29 | import Prelude 30 | 31 | 32 | -- TODO make all these constants part of ClientConfig 33 | 34 | -- Min/Max Time dilation. This is the maximum speedup of our own clock that 35 | -- we'll allow to catch up to the estimated server clock. Note that the min is 36 | -- greater than 0 meaning that we never stop or reverse time. 37 | 38 | minTimeDilation :: Float 39 | minTimeDilation = 0.9 40 | 41 | 42 | maxTimeDilation :: Float 43 | maxTimeDilation = 1.1 44 | 45 | 46 | -- Number of ping samples to maintain 47 | pingSamples :: Int 48 | pingSamples = 8 49 | 50 | 51 | -- Number of timing samples to maintain 52 | timingSamples :: Int 53 | timingSamples = 40 54 | 55 | 56 | -- Some state for managing clock synchronization 57 | data ClockSync = ClockSync 58 | -- On the last server time estimate: (client's local time, estimated server's local time) 59 | { csLastSample :: Maybe (Time, Time) 60 | , -- Last few samples of point times 61 | csPingSamples :: [Duration] 62 | , -- Last few samples of: (server time, estimated corresponding client time) 63 | -- relative to base. 64 | csTimingSamples :: [(Time, Time)] 65 | } 66 | 67 | 68 | csEstPing :: ClockSync -> Duration 69 | csEstPing (ClockSync{csPingSamples = xs}) = sum xs / (realToFrac $ length xs) 70 | 71 | 72 | -- | returns (off, drift) sutch that serverTime = (drift * clientTime) + offset 73 | csEstOffsetAndDrift :: ClockSync -> Maybe (Time, Time) 74 | csEstOffsetAndDrift (ClockSync{csTimingSamples = xs}) 75 | | nInt < pingSamples || slopDenom == 0 = Nothing 76 | -- TODO perhaps it's more efficient to just use https://en.wikipedia.org/wiki/Simple_linear_regression#Fitting_the_regression_line 77 | 78 | | otherwise = Just (offset, slope) 79 | where 80 | nInt = length xs 81 | n = fromIntegral nInt 82 | avg xs' = sum xs' / n 83 | avgServer = avg (fst <$> xs) 84 | avgClient = avg (snd <$> xs) 85 | slopNumer = sum [(s - avgServer) * (c - avgClient) | (s, c) <- xs] 86 | slopDenom = sum [(c - avgClient) ^ (2 :: Int64) | (_, c) <- xs] 87 | slope = slopNumer / slopDenom 88 | offset = avgServer - (slope * avgClient) 89 | 90 | 91 | -- | Initialize clock synchronization. 92 | initializeClockSync :: 93 | -- | Tick time (time per tick in seconds) 94 | Float -> 95 | -- | Get the current time from the system in seconds. 96 | IO Float -> 97 | -- | Returns: 98 | -- 99 | -- * Given some @extraTime@, Estimate the tick on the server when a message 100 | -- sent at @now + extraTime@ is received by the server plus some extraTime 101 | -- time. 102 | -- 103 | -- * Record a clock sync event. Given a heartbeat meassge, this is: client 104 | -- send time, server receive time, client receive (of the heart beat 105 | -- response) time) 106 | -- 107 | -- * analytics returns: 108 | -- 109 | -- * Ping 110 | -- 111 | -- * Estimated error from the server clock. This error occurs when we've 112 | -- committed to some time samples then realize that our measurements are 113 | -- off. Instead of immediately correcting, we simply dilate time (speeding 114 | -- up a bit or slowing down a bit) until the "effective" clock is 115 | -- corrected (see min/maxTimeDilation). On till corrected, our time 116 | -- estimates differ from what we really think the time is on the server, 117 | -- and that difference is the "estimated error". Specifically `error = 118 | -- servertime - effective time` 119 | IO (Float -> IO Tick, Float -> Float -> Float -> IO (), IO (Maybe (Float, Float))) 120 | initializeClockSync tickTime getTime = do 121 | clockSyncTVar :: TVar ClockSync <- newTVarIO (ClockSync Nothing [] []) 122 | let -- Estimate the tick on the server when a message sent at `now + extraTime` is 123 | -- received by the server plus some extraTime time. 124 | estimateServerTickPlusLatencyPlusBufferPlus :: Float -> IO Tick 125 | estimateServerTickPlusLatencyPlusBufferPlus extraTime = do 126 | clientTime <- getTime 127 | atomically $ do 128 | cs <- readTVar clockSyncTVar 129 | anaMay <- analytics' cs clientTime extraTime 130 | case anaMay of 131 | Nothing -> retry 132 | Just (_estServerTime, dilatedEstServerTime, _ping, newCS) -> do 133 | writeTVar clockSyncTVar newCS 134 | return (floor (dilatedEstServerTime / tickTime)) 135 | 136 | analytics :: IO (Maybe (Float, Float)) 137 | analytics = do 138 | clientTime <- getTime 139 | atomically $ do 140 | cs <- readTVar clockSyncTVar 141 | anaMay <- analytics' cs clientTime 0 142 | case anaMay of 143 | Nothing -> return Nothing 144 | Just (estServerTime, dilatedEstServerTime, ping, _newCS) -> do 145 | return $ Just (ping, estServerTime - dilatedEstServerTime) 146 | 147 | -- (estimated server time, estimated server time clamping time dilation, ping, ClockSync with the new sample point) 148 | analytics' :: ClockSync -> Time -> Float -> STM (Maybe (Float, Float, Float, ClockSync)) 149 | analytics' cs clientTime extraTime = do 150 | let offDriftMay = csEstOffsetAndDrift cs 151 | case offDriftMay of 152 | Nothing -> return Nothing 153 | Just (offset, drift) -> do 154 | let estServerTime = (drift * clientTime) + offset 155 | clampedEstServerTime = fromMaybe estServerTime $ 156 | do 157 | (lastClientTime, lastEstServerTime) <- csLastSample cs 158 | let targetTimeDilation = 159 | (estServerTime - lastEstServerTime) 160 | / (clientTime - lastClientTime) 161 | clampedTimeDilation = 162 | min (realToFrac maxTimeDilation) $ 163 | max (realToFrac minTimeDilation) $ 164 | targetTimeDilation 165 | return $ lastEstServerTime + (clampedTimeDilation * (clientTime - lastClientTime)) 166 | 167 | -- For now we're just on local host, so just add a small delay 168 | -- to the current time to estimate the server time. 169 | let elapsedTime = clampedEstServerTime 170 | latency = csEstPing newCS / 2 -- TODO I think adding latency is probably causing some annoying preceived input latency variablility. Rethink this! 171 | dilatedEstServerTime = (elapsedTime + latency + bufferTime + extraTime) 172 | newCS = cs{csLastSample = Just (clientTime, clampedEstServerTime)} 173 | ping = csEstPing newCS 174 | return $ Just (estServerTime + latency + bufferTime, dilatedEstServerTime, ping, newCS) 175 | 176 | recordClockSyncSample :: Float -> Float -> Float -> IO () 177 | recordClockSyncSample clientSendTime serverTime clientReceiveTime = do 178 | let pingSample = clientReceiveTime - clientSendTime 179 | latency = pingSample / 2 180 | timingSample = 181 | ( serverTime 182 | , latency + clientSendTime 183 | ) 184 | 185 | _cs' <- atomically $ do 186 | cs <- readTVar clockSyncTVar 187 | let cs' = 188 | ClockSync 189 | { csLastSample = csLastSample cs 190 | , csPingSamples = take pingSamples (pingSample : csPingSamples cs) 191 | , csTimingSamples = take timingSamples (timingSample : csTimingSamples cs) 192 | } 193 | writeTVar clockSyncTVar cs' 194 | return cs' 195 | 196 | -- putStrLn $ "Ping: " ++ show (csEstPing cs') 197 | -- forM_ (csEstOffsetAndDrift cs') $ \(off, drift) -> do 198 | -- putStrLn $ "Offset: " ++ show off 199 | -- putStrLn $ "Drift: " ++ show drift 200 | return () 201 | 202 | return (estimateServerTickPlusLatencyPlusBufferPlus, recordClockSyncSample, analytics) 203 | -------------------------------------------------------------------------------- /src/Alpaca/NetCode/Internal/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE PatternSynonyms #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE RecordWildCards #-} 15 | {-# LANGUAGE RecursiveDo #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# LANGUAGE StandaloneDeriving #-} 18 | {-# LANGUAGE TemplateHaskell #-} 19 | {-# LANGUAGE TupleSections #-} 20 | {-# LANGUAGE TypeApplications #-} 21 | {-# LANGUAGE TypeFamilies #-} 22 | {-# LANGUAGE ViewPatterns #-} 23 | 24 | -- | Rollback and replay based game networking 25 | module Alpaca.NetCode.Internal.Common where 26 | 27 | import Control.Concurrent (forkIO, newChan, readChan, threadDelay, writeChan) 28 | import Control.Concurrent.STM as STM 29 | import Control.Monad (forever, when) 30 | import Data.Hashable (Hashable) 31 | import Data.Int (Int64) 32 | import qualified Data.List as L 33 | import Data.Map (Map) 34 | import qualified Data.Map as M 35 | import Data.Time.Clock 36 | import Data.Word (Word8) 37 | import Flat 38 | import System.Random (randomRIO) 39 | import Prelude 40 | 41 | 42 | -- Constants 43 | 44 | -- Note above, we don't actually step the simulation here. We leave 45 | -- that all up to the draw function. All we need to do is submit 46 | -- inputs once per tick to the server. 47 | 48 | -- | How many missing inputs to request at a time 49 | maxRequestAuthInputs :: Int 50 | maxRequestAuthInputs = 100 51 | 52 | 53 | -- | TODO I need some proper logging mechanism. 54 | debugStrLn :: String -> IO () 55 | debugStrLn _ = return () 56 | 57 | 58 | -- This can be thought of as how far the authoritative simulation is behind the 59 | -- clients. Making this large does NOT affect latency. It DOES affect how far 60 | -- back clients might need to roll back their simulation. Too small of a buffer 61 | -- time means inputs will tend to be dropped (not made authoritative) because 62 | -- they arrived a bit late. Too high of a buffer time means clients can 63 | -- experience more pronounced popping/corrections due to large rollback. 64 | -- 65 | -- TODO This seems like a bit of a hack. We could instead use a buffer based on 66 | -- out jitter. On the other hand we want to avoid time dilation, so this should 67 | -- not be overly dynamic. 68 | bufferTime :: Duration 69 | bufferTime = 0.03 -- seconds 70 | 71 | 72 | type Time = Float -- seconds 73 | 74 | 75 | type Duration = Float -- seconds 76 | 77 | 78 | -- | The game is broken into discrete ticks starting from 0. 79 | newtype Tick = Tick Int64 80 | deriving stock (Show) 81 | deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Hashable, Flat) 82 | 83 | 84 | newtype PlayerId = PlayerId {unPlayerId :: Word8} 85 | deriving stock (Show) 86 | deriving newtype (Eq, Ord, Num, Hashable) 87 | 88 | 89 | deriving newtype instance (Flat PlayerId) 90 | 91 | 92 | -- | Settings for simulating network conditions. Packets in both the send and 93 | -- receive directions are randomly dropped or delayed by `simPing/2` plus some 94 | -- random duration between `-simJitter` and `simJitter`. 95 | data SimNetConditions = SimNetConditions 96 | { -- | Extra ping (seconds) 97 | simPing :: Float 98 | , -- | Extra jitter (seconds). Should be less than simPing. 99 | simJitter :: Float 100 | , -- | Package loss (0 = no packet loss, 1 = 100% packet loss). 101 | simPackageLoss :: Float 102 | } deriving (Show, Read, Eq, Ord) 103 | 104 | 105 | -- data NetConfig = NetConfig 106 | -- { -- | Add this latency (in seconds) to all input. Players will experience 107 | -- -- this latency even during perfect prediction, but the latency will be 108 | -- -- consistent and reduces artifacts because input messages will be received 109 | -- -- earlier (at least relative to their intended tick). In the extream case, 110 | -- -- if this is set to something higher than ping, there will be no miss 111 | -- -- predictions: all clients will receive inputs before rendering their 112 | -- -- corresponding tick. 113 | -- inputLatency :: Float 114 | -- , -- | Simulate: 115 | -- -- * Ping (seconds) 116 | -- -- * Jitter (seconds) 117 | -- -- * Percentage Package loss (0 = no packet loss, 1 = 100% packet loss) 118 | -- simulatedNetConditions :: Maybe (Float, Float, Float) 119 | -- -- -- | number of times to duplicate unreliable messages (e.g. input messages) 120 | -- -- -- to make them more reliable. 121 | -- -- msgDuplication :: Int64 122 | -- } 123 | 124 | simulateNetConditions :: 125 | -- | Send function 126 | (msg -> IO ()) -> 127 | -- | Receive function (blocking) 128 | (IO msg) -> 129 | -- | Simulated ping/jitter/packetloss[0-1] 130 | Maybe SimNetConditions -> 131 | -- | New send and receive functions. 132 | IO 133 | ( msg -> IO () 134 | , IO msg 135 | ) 136 | simulateNetConditions doSendMsg doRecvMsg simMay = case simMay of 137 | Nothing -> return (doSendMsg, doRecvMsg) 138 | Just (SimNetConditions ping jitter loss) -> do 139 | -- Start a thread that just writes received messages into a chan 140 | recvChan <- newChan 141 | _recvThreadId <- forkIO $ 142 | forever $ do 143 | msg <- doRecvMsg 144 | dropPacket <- (<= loss) <$> randomRIO (0, 1) 145 | when (not dropPacket) $ do 146 | _ <- forkIO $ do 147 | jitterT <- randomRIO (negate jitter, jitter) 148 | let latency = max 0 ((ping / 2) + jitterT) 149 | threadDelay (round $ latency * 1000000) 150 | writeChan recvChan msg 151 | return () 152 | return 153 | ( -- Sending a message just starts a thread that delays the send. 154 | \msg -> do 155 | dropPacket <- (< loss) <$> randomRIO (0, 1) 156 | when (not dropPacket) $ do 157 | jitterT <- randomRIO (negate jitter, jitter) 158 | let latency = max 0 ((ping / 2) + jitterT) 159 | _ <- forkIO $ do 160 | threadDelay (round $ latency * 1000000) 161 | doSendMsg msg 162 | return () 163 | , readChan recvChan 164 | ) 165 | 166 | 167 | playCommon :: 168 | Real a => 169 | a -> 170 | ( Float -> -- seconds per tick 171 | IO Float -> -- get time 172 | (UTCTime -> STM ()) -> -- Reset timer to 0 at the given time 173 | IO b 174 | ) -> 175 | IO b 176 | playCommon 177 | tickFreq 178 | go = 179 | do 180 | let tickTime :: Float 181 | tickTime = 1 / realToFrac tickFreq 182 | 183 | tick0SysTimTVar <- newTVarIO undefined 184 | 185 | let getTime :: IO Float 186 | getTime = do 187 | tick0SysTime <- atomically $ readTVar tick0SysTimTVar 188 | timeUTC <- getCurrentTime 189 | return $ realToFrac $ timeUTC `diffUTCTime` tick0SysTime 190 | 191 | resetTime :: UTCTime -> STM () 192 | resetTime = writeTVar tick0SysTimTVar 193 | 194 | currentTime <- getCurrentTime 195 | atomically $ resetTime currentTime 196 | 197 | go tickTime getTime resetTime 198 | 199 | 200 | data NetMsg input 201 | = -- Client -> Server 202 | Msg_Connect 203 | Float -- Client's local time (used for initial clock sync). 204 | | -- Server -> Client 205 | Msg_Connected PlayerId 206 | | -- | Client -> Server: Regularly sent. Used for clock sync and to acknowledge receiving auth ticks up to a given point. 207 | Msg_Heartbeat 208 | Float -- Client's local time (used for clock sync). 209 | | -- Client -> server 210 | Msg_Ack 211 | Tick -- Client's max known auth inputs tick such that there are no missing ticks before it. 212 | | -- | Server -> Client: Sent in response to Msg_Connect. This indicates the 213 | -- clients PlayerId 214 | Msg_HeartbeatResponse 215 | -- Clock time on the server at Tick 0 is alwyas just 0. 216 | Float -- Clock time on the client when the connect message was sent. 217 | Float -- Clock time on the server when the connect message was received. 218 | | -- | Server -> Client: complete authoritative inputs for a run of ticks 219 | Msg_AuthInput 220 | Tick -- Start tick (inclusive) 221 | (CompactMaps PlayerId input) -- auth ticks starting at the given tick 222 | (CompactMaps PlayerId input) -- non-auth ticks (hints) starting after the auth ticks 223 | | -- | A non-authoritative hint for some input. 224 | Msg_HintInput Tick PlayerId input 225 | | Msg_SubmitInput [(Tick, input)] 226 | deriving stock (Show, Generic) 227 | 228 | 229 | deriving instance Flat input => Flat (NetMsg input) 230 | 231 | 232 | newtype CompactMaps key value = CompactMaps [([key], [[value]])] 233 | deriving stock (Generic, Show) 234 | 235 | 236 | deriving newtype instance (Flat key, Flat value) => Flat (CompactMaps key value) 237 | 238 | 239 | -- | Convert a list of maps to a datastructure that is more compact when 240 | -- serialized by flat. This is more compact assuming that many subsequent maps 241 | -- have the same key set. 242 | {-# SPECIALIZE toCompactMaps :: [Map PlayerId input] -> CompactMaps PlayerId input #-} 243 | toCompactMaps :: Eq key => [Map key value] -> CompactMaps key value 244 | toCompactMaps maps = 245 | CompactMaps 246 | [ (runKeys, M.elems <$> run) 247 | | run <- L.groupBy (\a b -> M.keysSet a == M.keysSet b) maps 248 | , let runKeys = M.keys (head run) 249 | ] 250 | 251 | 252 | -- | Inverse of toCompactMaps 253 | {-# SPECIALIZE fromCompactMaps :: CompactMaps PlayerId input -> [Map PlayerId input] #-} 254 | fromCompactMaps :: Eq key => CompactMaps key value -> [Map key value] 255 | fromCompactMaps (CompactMaps runs) = 256 | [ M.fromAscList (zip keys values) 257 | | (keys, valuess) <- runs 258 | , values <- valuess 259 | ] 260 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /src/Alpaca/NetCode/Internal/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RecursiveDo #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TupleSections #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# LANGUAGE TypeFamilies #-} 21 | 22 | -- | Rollback and replay based game networking 23 | module Alpaca.NetCode.Internal.Server 24 | ( runServerWith' 25 | , ServerConfig (..) 26 | , defaultServerConfig 27 | ) where 28 | 29 | import Control.Applicative 30 | import Control.Concurrent (forkIO, killThread, threadDelay) 31 | import Control.Concurrent.STM as STM 32 | import Control.Monad (forM_, forever, join, when, forM) 33 | import Data.Coerce (coerce) 34 | import Data.IntMap (IntMap) 35 | import qualified Data.IntMap as IM 36 | import Data.List (dropWhileEnd, foldl') 37 | import qualified Data.Map as M 38 | import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) 39 | import Data.Time (getCurrentTime) 40 | import Flat 41 | import Prelude 42 | 43 | import Alpaca.NetCode.Internal.Common 44 | 45 | -- | Configuration options specific to the server. 46 | data ServerConfig = ServerConfig 47 | { 48 | -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same 49 | -- across all clients and the server. Packet rate and hence network bandwidth 50 | -- will scale linearly with this the tick rate. 51 | scTickRate :: Int 52 | -- | Seconds of not receiving packets from a client before disconnecting that 53 | -- client. 54 | , scClientTimeout :: Float 55 | } deriving (Show, Read, Eq, Ord) 56 | 57 | -- | Sensible defaults for @ServerConfig@ based on the tick rate. 58 | defaultServerConfig :: 59 | -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same 60 | -- across all clients and the server. Packet rate and hence network bandwidth 61 | -- will scale linearly with this the tick rate. 62 | Int 63 | -> ServerConfig 64 | defaultServerConfig tickRate = ServerConfig 65 | { scTickRate = tickRate 66 | , scClientTimeout = 5 67 | } 68 | 69 | -- | Run a server for a single game. This will block until the game ends, 70 | -- specifically when all players have disconnected. 71 | runServerWith' :: 72 | forall input clientAddress. 73 | ( Eq input 74 | , Flat input 75 | , Show clientAddress 76 | , Ord clientAddress 77 | ) => 78 | -- | Function to send messages to clients. The underlying communication 79 | -- protocol need only guarantee data integrity but is otherwise free to drop 80 | -- and reorder packets. Typically this is backed by a UDP socket. 81 | (NetMsg input -> clientAddress -> IO ()) -> 82 | -- | Blocking function to receive messages from the clients. Has the same 83 | -- reliability requirements as the send function. 84 | (IO (NetMsg input, clientAddress)) -> 85 | -- | Optional simulation of network conditions. In production this should be 86 | -- `Nothing`. May differ between clients. 87 | Maybe SimNetConditions -> 88 | -- | The 'defaultServerConfig' works well for most cases. 89 | ServerConfig -> 90 | -- | Initial input for new players. Must be the same across all clients and 91 | -- the server. See 'Alpaca.NetCode.runClient'. 92 | input -> 93 | IO () 94 | runServerWith' sendToClient' recvFromClient' simNetConditionsMay serverConfig input0 = playCommon (scTickRate serverConfig) $ \tickTime getTime resetTime -> forever $ do 95 | (sendToClient'', recvFromClient) <- simulateNetConditions 96 | (uncurry sendToClient') 97 | recvFromClient' 98 | simNetConditionsMay 99 | let sendToClient = curry sendToClient'' 100 | debugStrLn "Waiting for clients" 101 | 102 | -- Authoritative Map from tick and PlayerId to inputs. The inner map is 103 | -- always complete (e.g. if we have the IntMap for tick i, then it contains 104 | -- the inputs for *all* known players) 105 | authInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- newTVarIO (IM.singleton 0 M.empty) 106 | 107 | -- The next Tick i.e. the first non-frozen tick. All ticks before this 108 | -- one have been frozen (w.r.t authInputsTVar). 109 | nextTickTVar :: TVar Tick <- newTVarIO 1 110 | 111 | -- Known players as of now. Nothing means the host (me). 112 | playersTVar :: TVar (M.Map clientAddress PlayerData) <- newTVarIO M.empty 113 | -- Known Players ( 114 | -- , last time for which a message was received 115 | -- ) 116 | 117 | -- Next available PlayerId 118 | nextPlayerIdTVar :: TVar PlayerId <- newTVarIO 0 119 | 120 | -- As the host we're authoritative and always simulating significantly 121 | -- behind clients. This allows for ample time to receive inputs even 122 | -- with large ping and jitter. Although the authoritative simulation is 123 | -- significantly behind clients, we send input hints eagerly, and that 124 | -- allows clients to make accurate predictions and hence they don't 125 | -- perceive the lag in authoritative inputs. 126 | 127 | -- Main message processing loop 128 | msgProcessingTID <- forkIO $ 129 | forever $ do 130 | (msg, sender) <- recvFromClient 131 | 132 | -- Handle the message 133 | serverReceiveTimeMay <- case msg of 134 | Msg_Connected{} -> do 135 | debugStrLn $ "Server received unexpected Msg_Connected from " ++ show sender ++ ". Ignoring." 136 | return Nothing 137 | Msg_AuthInput{} -> do 138 | debugStrLn $ "Server received unexpected Msg_AuthInput from " ++ show sender ++ ". Ignoring." 139 | return Nothing 140 | Msg_HeartbeatResponse{} -> do 141 | debugStrLn $ "Server received unexpected Msg_HeartbeatResponse from " ++ show sender ++ ". Ignoring." 142 | return Nothing 143 | Msg_HintInput{} -> do 144 | debugStrLn $ "Server received unexpected Msg_HintInput from " ++ show sender ++ ". Perhaps you meant to send a Msg_SubmitInput. Ignoring." 145 | return Nothing 146 | Msg_Connect clientSendTime -> do 147 | -- new client connection 148 | currentTimeUTC <- getCurrentTime 149 | currentTime <- getTime 150 | join $ 151 | atomically $ do 152 | playerMay <- M.lookup sender <$> readTVar playersTVar 153 | (pid, debugMsg, serverReceiveTime) <- case playerMay of 154 | Nothing -> do 155 | -- New player 156 | pid <- readTVar nextPlayerIdTVar 157 | writeTVar nextPlayerIdTVar (pid + 1) 158 | players <- readTVar playersTVar 159 | let isFirstConnection = M.null players 160 | -- We only start the game on first connection, so must reset the timer 161 | serverReceiveTime <- 162 | if isFirstConnection 163 | then do 164 | resetTime currentTimeUTC 165 | return 0 166 | else return currentTime 167 | writeTVar playersTVar (M.insert sender (PlayerData{playerId = pid, maxAuthTick = 0, lastMesgRcvTime = serverReceiveTime}) players) 168 | return (pid, Just ("Connected " ++ show sender ++ " as " ++ show pid), serverReceiveTime) 169 | Just PlayerData{..} -> do 170 | -- Existing player 171 | return (playerId, Nothing, currentTime) 172 | return $ do 173 | sendToClient (Msg_Connected pid) sender 174 | sendToClient (Msg_HeartbeatResponse clientSendTime serverReceiveTime) sender 175 | mapM_ debugStrLn debugMsg 176 | return (Just serverReceiveTime) 177 | Msg_Heartbeat clientSendTime -> do 178 | serverReceiveTime <- getTime 179 | isConnected <- atomically (isJust . M.lookup sender <$> readTVar playersTVar) 180 | when isConnected $ sendToClient (Msg_HeartbeatResponse clientSendTime serverReceiveTime) sender 181 | return (Just serverReceiveTime) 182 | Msg_Ack clientMaxAuthTick -> do 183 | atomically $ modifyTVar playersTVar (M.update (\pd -> Just $ pd{maxAuthTick = clientMaxAuthTick}) sender) 184 | Just <$> getTime 185 | Msg_SubmitInput submittedInputs -> do 186 | msgMay <- atomically $ do 187 | -- Check that the sender is connected. 188 | playerMay <- M.lookup sender <$> readTVar playersTVar 189 | case playerMay of 190 | Nothing -> return [Just $ "Got Msg_SubmitInput from client that is not yet connected " ++ show sender] 191 | Just PlayerData{..} -> forM submittedInputs $ \(tick, input) -> do 192 | -- Check that the tick time has not already been simulated. 193 | nextTick <- readTVar nextTickTVar 194 | -- TODO upper bound on allowed tick time. 195 | if tick < nextTick 196 | then 197 | return $ 198 | Just $ 199 | "Late Msg_Input from " ++ show playerId 200 | ++ " for " 201 | ++ show tick 202 | ++ " but already simulated up to " 203 | ++ show (nextTick - 1) 204 | ++ ". Ignoring." 205 | else do 206 | inputs <- readTVar authInputsTVar 207 | let inptsAtTick = fromMaybe M.empty (inputs IM.!? fromIntegral tick) 208 | case inptsAtTick M.!? playerId of 209 | Just existingInput 210 | -- Duplicate message. Silently ignore 211 | | existingInput == input -> return Nothing 212 | -- Different input for the same tick! 213 | | otherwise -> 214 | return $ 215 | Just $ 216 | "Received inputs from " ++ show playerId ++ " for " ++ show tick 217 | ++ " but already have inputs for that time with a DIFFERENT value! Ignoring." 218 | -- First time we're hearing of this input. Store it. 219 | Nothing -> do 220 | writeTVar authInputsTVar $ 221 | IM.insert 222 | (fromIntegral tick) 223 | (M.insert playerId input inptsAtTick) 224 | inputs 225 | 226 | return Nothing 227 | mapM_ debugStrLn (catMaybes msgMay) 228 | Just <$> getTime 229 | 230 | -- set receive time for players 231 | forM_ serverReceiveTimeMay $ \serverReceiveTime -> 232 | atomically $ 233 | modifyTVar 234 | playersTVar 235 | ( M.update 236 | (\player -> Just player{lastMesgRcvTime = serverReceiveTime}) 237 | sender 238 | ) 239 | 240 | -- Wait for a connection 241 | atomically $ do 242 | players <- readTVar playersTVar 243 | STM.check $ not $ M.null players 244 | 245 | debugStrLn "Client connected. Starting game." 246 | 247 | -- Disconnect players after a timeout 248 | disconnectTID <- forkIO $ 249 | forever $ do 250 | -- Find next possilbe time to disconnect a player 251 | oldestMsgRcvTime <- atomically (minimum . fmap lastMesgRcvTime . M.elems <$> readTVar playersTVar) 252 | let disconnectTime = oldestMsgRcvTime + scClientTimeout serverConfig 253 | 254 | -- Wait till the disconnect time (plus a bit to really make sure we pass the threshold) 255 | t <- getTime 256 | when (t < disconnectTime) $ 257 | threadDelay (round (((disconnectTime - t) + 0.01) * 1000000)) 258 | 259 | -- Kick players as needed 260 | currentTime <- getTime 261 | kickedPlayers <- atomically $ do 262 | players <- readTVar playersTVar 263 | let (retainedPlayers, kickedPlayers) = M.partition (\PlayerData{..} -> lastMesgRcvTime + scClientTimeout serverConfig > currentTime) players 264 | writeTVar playersTVar retainedPlayers 265 | return kickedPlayers 266 | when (not (M.null kickedPlayers)) $ debugStrLn $ "Disconnect players due to timeout: " ++ show [pid | PlayerData{playerId = PlayerId pid} <- M.elems kickedPlayers] 267 | 268 | -- Main "simulation" loop 269 | simTID <- forkIO $ 270 | forever $ do 271 | -- Calculate target tick according to current time 272 | currTime <- getTime 273 | let targetTick = floor $ currTime / tickTime 274 | 275 | -- Fill auth inputs 276 | atomically $ do 277 | nextAuthTick <- readTVar nextTickTVar 278 | 279 | -- Freeze ticks. 280 | writeTVar nextTickTVar (targetTick + 1) 281 | 282 | -- Advance auth inputs up to target tick. 283 | knownPlayers <- readTVar playersTVar 284 | authInputs <- readTVar authInputsTVar 285 | let nextAuthTickInputs = authInputs IM.! fromIntegral (nextAuthTick - 1) 286 | writeTVar authInputsTVar $ 287 | fst $ 288 | foldl' 289 | ( \(authInputs', prevInputs) currTick -> 290 | let -- Fill inputs for the current tick. 291 | currInputsRaw = fromMaybe M.empty (IM.lookup (fromIntegral currTick) authInputs) 292 | currInputs = 293 | M.fromList 294 | [ ( pidInt 295 | , fromMaybe 296 | input0 297 | ( currInputsRaw M.!? pid 298 | <|> prevInputs M.!? pid 299 | ) 300 | ) 301 | | pid <- playerId <$> M.elems knownPlayers 302 | , let pidInt = coerce pid 303 | ] 304 | in (IM.insert (fromIntegral currTick) currInputs authInputs', currInputs) 305 | ) 306 | (authInputs, nextAuthTickInputs) 307 | [nextAuthTick .. targetTick] 308 | 309 | -- broadcast some auth inputs 310 | knownPlayers <- atomically $ readTVar playersTVar 311 | (authInputs, nextAuthTick) <- atomically $ do 312 | authInputs <- readTVar authInputsTVar 313 | nextAuthTick <- readTVar nextTickTVar 314 | return (authInputs, nextAuthTick) 315 | forM_ (M.assocs knownPlayers) $ \(sock, playerData) -> do 316 | let lastAuthTick = maxAuthTick playerData 317 | (_, _, inputsToSendIntMap') = IM.splitLookup (fromIntegral lastAuthTick) authInputs 318 | (inputsToSendIntMap, firstHint, _) = IM.splitLookup (fromIntegral nextAuthTick) inputsToSendIntMap' 319 | inputsToSend = take maxRequestAuthInputs $ IM.elems inputsToSendIntMap 320 | hintsToSendCount = maxRequestAuthInputs - IM.size inputsToSendIntMap 321 | hintsToSend = 322 | fmap (fromMaybe M.empty) $ 323 | dropWhileEnd isNothing $ 324 | take hintsToSendCount $ 325 | firstHint : 326 | [ authInputs IM.!? fromIntegral hintTick 327 | | hintTick <- [succ nextAuthTick ..] 328 | ] 329 | when (not $ null inputsToSend) $ 330 | sendToClient 331 | ( Msg_AuthInput 332 | (lastAuthTick + 1) 333 | (toCompactMaps inputsToSend) 334 | (toCompactMaps hintsToSend) 335 | ) 336 | sock 337 | 338 | -- Sleep thread till the next tick. 339 | currTime' <- getTime 340 | let nextTick = targetTick + 1 341 | nextTickTime = fromIntegral nextTick * tickTime 342 | timeTillNextTick = nextTickTime - currTime' 343 | threadDelay $ round $ 1000000 * timeTillNextTick 344 | 345 | -- Wait till all players quit 346 | atomically $ do 347 | players <- readTVar playersTVar 348 | STM.check $ M.null players 349 | 350 | debugStrLn "No more clients, Stopping game!" 351 | 352 | mapM_ killThread [msgProcessingTID, disconnectTID, simTID] 353 | 354 | -- | Per player info stored by the server 355 | data PlayerData = PlayerData 356 | { -- | last tick for which auth inputs were sent from the server 357 | playerId :: PlayerId 358 | , -- | Client's max known auth inputs tick such that there are no missing 359 | -- ticks before it. 360 | maxAuthTick :: Tick 361 | , -- | Last server time at which a message was received from this player. 362 | lastMesgRcvTime :: Float 363 | } 364 | -------------------------------------------------------------------------------- /src/Alpaca/NetCode/Internal/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE RecordWildCards #-} 16 | {-# LANGUAGE RecursiveDo #-} 17 | {-# LANGUAGE ScopedTypeVariables #-} 18 | {-# LANGUAGE StandaloneDeriving #-} 19 | {-# LANGUAGE TemplateHaskell #-} 20 | {-# LANGUAGE TupleSections #-} 21 | {-# LANGUAGE TypeApplications #-} 22 | {-# LANGUAGE TypeFamilies #-} 23 | 24 | -- | Rollback and replay based game networking 25 | module Alpaca.NetCode.Internal.Client ( 26 | runClientWith', 27 | ClientConfig (..), 28 | defaultClientConfig, 29 | Client, 30 | clientPlayerId, 31 | clientSample, 32 | clientSample', 33 | clientSetInput, 34 | clientStop, 35 | ) where 36 | 37 | import Alpaca.NetCode.Internal.ClockSync 38 | import Alpaca.NetCode.Internal.Common 39 | import Control.Concurrent (forkIO, killThread, threadDelay) 40 | import Control.Concurrent.STM as STM 41 | import Control.Monad 42 | import Data.Int (Int64) 43 | import Data.IntMap (IntMap) 44 | import qualified Data.IntMap as IM 45 | import qualified Data.Map as M 46 | import Data.Maybe (catMaybes, fromMaybe, isJust) 47 | import qualified Data.Set as S 48 | import Flat 49 | import Prelude 50 | 51 | 52 | -- | A Client. You'll generally obtain this via 'Alpaca.NetCode.runClient'. 53 | data Client world input = Client 54 | { -- | The client's @PlayerId@ 55 | clientPlayerId :: PlayerId 56 | , -- | Sample the world state. First, This will estimate the current tick 57 | -- based on ping and clock synchronization with the server. Then, the world 58 | -- state will be rollback and inputs replayed as necessary. This returns: 59 | -- 60 | -- * New authoritative world states in chronological order since the last 61 | -- sample time. These world states are the True world states at each tick. 62 | -- This list will be empty if no new authoritative world states have been 63 | -- derived since that last call to this sample function. Though it's often 64 | -- simpler to just use the predicted world state, you can use these 65 | -- authoritative world states to render output when you're not willing to 66 | -- miss-predict but are willing to have greater latency. If the client has 67 | -- been stopped, this will be an empty list. 68 | -- 69 | -- * The predicted current world state. This extrapolates past the latest 70 | -- know authoritative world state by assuming no user inputs have changed 71 | -- (unless otherwise known e.g. our own player's inputs are known). If the 72 | -- client has been stopped, this will return the last predicted world. 73 | clientSample' :: IO ([world], world) 74 | , -- | Set the client's current input. 75 | clientSetInput :: input -> IO () 76 | , -- | Stop the client. 77 | clientStop :: IO () 78 | } 79 | 80 | 81 | -- | Sample the current world state. 82 | -- 83 | -- . First, This will estimate the current tick based on ping and clock 84 | -- synchronization with the server. Then, this extrapolates past the latest know 85 | -- authoritative world state by assuming no user inputs have changed (unless 86 | -- otherwise known e.g. our own player's inputs are known). If the client has 87 | -- been stopped, this will return the last predicted world. 88 | clientSample :: Client world input -> IO world 89 | clientSample client = snd <$> clientSample' client 90 | 91 | 92 | -- | Configuration options specific to clients. 93 | data ClientConfig = ClientConfig 94 | { -- | Tick rate (ticks per second). Typically @30@ or @60@. Must be the same 95 | -- across all clients and the server. Packet rate and hence network bandwidth 96 | -- will scale linearly with this the tick rate. 97 | ccTickRate :: Int 98 | , -- | Add this constant amount of latency (in seconds) to this client's inputs. 99 | -- A good value is @0.03@ or something between @0@ and @0.1@. May differ 100 | -- between clients. 101 | -- 102 | -- Too high of a value and the player will get annoyed at the extra input 103 | -- latency. On the other hand, a higher value means less miss-predictions of 104 | -- other clients. In the extreme case, set to something higher than ping, 105 | -- there will be no miss predictions: all clients will receive inputs before 106 | -- rendering the corresponding tick. 107 | ccFixedInputLatency :: Float 108 | , -- | Maximum number of ticks to predict when sampling. 'defaultClientConfig' 109 | -- uses @ccTickRate / 2@. If the client is this many ticks behind the current 110 | -- tick, it will simply stop at an earlier tick. You may want to scale this 111 | -- value along with the tick rate. May differ between clients. 112 | ccMaxPredictionTicks :: Int 113 | , -- | If the client's latest known authoritative world is this many ticks 114 | -- behind the current tick, no prediction will be done at all when sampling. 115 | -- 'defaultClientConfig' uses @ccTickRate * 3@. Useful because want to save 116 | -- CPU cycles for catching up with the server. You may want to scale this 117 | -- value along with the tick rate. May differ between clients. 118 | ccResyncThresholdTicks :: Int 119 | , -- | When submitting inputs to the server, we also send a copy of 120 | -- @ccSubmitInputDuplication@ many recently submitted inputs in order to 121 | -- mittigate the effect for dropped packets. 'defaultClientConfig' 122 | -- uses @15@. 123 | ccSubmitInputDuplication :: Int 124 | } 125 | deriving (Show, Read, Eq, Ord) 126 | 127 | 128 | -- | Sensible defaults for @ClientConfig@ based on the tick rate. 129 | defaultClientConfig :: 130 | -- | Tick rate (ticks per second). Must be the same across all clients and the 131 | -- server. Packet rate and hence network bandwidth will scale linearly with 132 | -- this the tick rate. 133 | Int -> 134 | ClientConfig 135 | defaultClientConfig tickRate = 136 | ClientConfig 137 | { ccTickRate = tickRate 138 | , ccFixedInputLatency = 0.03 139 | , ccMaxPredictionTicks = tickRate `div` 2 140 | , ccResyncThresholdTicks = tickRate * 3 141 | , ccSubmitInputDuplication = 15 142 | } 143 | 144 | 145 | -- | Start a client. This blocks until the initial handshake with the 146 | -- server is finished. 147 | runClientWith' :: 148 | forall world input. 149 | Flat input => 150 | -- | Function to send messages to the server. The underlying communication 151 | -- protocol need only guarantee data integrity but is otherwise free to drop 152 | -- and reorder packets. Typically this is backed by a UDP socket. 153 | (NetMsg input -> IO ()) -> 154 | -- | Blocking function to receive messages from the server. Has the same 155 | -- reliability requirements as the send function. 156 | (IO (NetMsg input)) -> 157 | -- | Optional simulation of network conditions. In production this should be 158 | -- `Nothing`. May differ between clients. 159 | Maybe SimNetConditions -> 160 | -- | The 'defaultClientConfig' works well for most cases. 161 | ClientConfig -> 162 | -- | Initial input for new players. Must be the same across all clients and 163 | -- the server. See 'Alpaca.NetCode.runClient'. 164 | input -> 165 | -- | Initial world state. Must be the same across all clients. 166 | world -> 167 | -- | A deterministic stepping function (for a single tick). Must be the same 168 | -- across all clients and the server. See 'Alpaca.NetCode.runClient'. 169 | ( M.Map PlayerId input -> 170 | Tick -> 171 | world -> 172 | world 173 | ) -> 174 | IO (Client world input) 175 | runClientWith' sendToServer' rcvFromServer' simNetConditionsMay clientConfig input0 world0 stepOneTick = playCommon (ccTickRate clientConfig) $ \tickTime getTime _resetTime -> do 176 | (sendToServer, rcvFromServer) <- 177 | simulateNetConditions 178 | sendToServer' 179 | rcvFromServer' 180 | simNetConditionsMay 181 | 182 | -- Authoritative Map from tick and PlayerId to inputs. The inner map is 183 | -- always complete (e.g. if we have the IntMap for tick i, then it contains 184 | -- the inputs for *all* known players) 185 | authInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- newTVarIO (IM.singleton 0 M.empty) 186 | 187 | -- Tick to authoritative world state. 188 | authWorldsTVar :: TVar (IntMap world) <- newTVarIO (IM.singleton 0 world0) 189 | 190 | -- Max known auth inputs tick without any prior missing ticks. 191 | maxAuthTickTVar :: TVar Tick <- newTVarIO 0 192 | 193 | -- This client/host's PlayerId. Initially nothing, then set to Just the 194 | -- player ID on connection to the server. This is a constant thereafter. 195 | myPlayerIdTVar <- newTVarIO (Nothing :: Maybe PlayerId) 196 | 197 | -- Non-authoritative Map from tick and PlayerId to inputs. The inner map 198 | -- is NOT always complete (e.g. if we have the IntMap for tick i, then 199 | -- it may or may not yet contain all the inputs for *all* known players). 200 | hintInputsTVar :: TVar (IntMap (M.Map PlayerId input)) <- newTVarIO (IM.singleton 0 M.empty) 201 | 202 | -- Clock Sync 203 | (estimateServerTickPlusLatencyPlusBufferPlus, recordClockSyncSample, clockAnalytics) <- initializeClockSync tickTime getTime 204 | let estimateServerTickPlusLatencyPlusBuffer = estimateServerTickPlusLatencyPlusBufferPlus 0 205 | 206 | -- Keep trying to connect to the server. 207 | heartbeatTid <- forkIO $ 208 | forever $ do 209 | clientSendTime <- getTime 210 | isConnected <- isJust <$> atomically (readTVar myPlayerIdTVar) 211 | sendToServer ((if isConnected then Msg_Heartbeat else Msg_Connect) clientSendTime) 212 | isClockReady <- isJust <$> clockAnalytics 213 | threadDelay $ 214 | if isClockReady 215 | then 500000 -- 0.5 seconds 216 | else 50000 -- 0.05 seconds 217 | 218 | -- Main message processing loop 219 | msgLoopTid <- forkIO $ 220 | forever $ do 221 | msg <- rcvFromServer 222 | case msg of 223 | Msg_Connect{} -> debugStrLn "Client received unexpected Msg_Connect from the server. Ignoring." 224 | Msg_Connected playerId -> do 225 | join $ 226 | atomically $ do 227 | playerIdMay <- readTVar myPlayerIdTVar 228 | case playerIdMay of 229 | Nothing -> do 230 | writeTVar myPlayerIdTVar (Just playerId) 231 | return (debugStrLn $ "Connected! " ++ show playerId) 232 | Just playerId' -> return $ debugStrLn $ "Got Msg_Connected " ++ show playerId' ++ "but already connected (with " ++ show playerId 233 | Msg_SubmitInput{} -> debugStrLn "Client received unexpected Msg_SubmitInput from the server. Ignoring." 234 | Msg_Ack{} -> 235 | debugStrLn "Client received unexpected Msg_Ack from the server. Ignoring." 236 | Msg_Heartbeat{} -> 237 | debugStrLn "Client received unexpected Msg_Heartbeat from the server. Ignoring." 238 | Msg_HeartbeatResponse clientSendTime serverReceiveTime -> do 239 | -- Record times for ping/clock sync. 240 | clientReceiveTime <- getTime 241 | recordClockSyncSample clientSendTime serverReceiveTime clientReceiveTime 242 | Msg_AuthInput headTick authInputssCompact hintInputssCompact -> do 243 | let authInputss = fromCompactMaps authInputssCompact 244 | let hintInputss = fromCompactMaps hintInputssCompact 245 | resMsgs <- do 246 | -- Update maxAuthTickTVar if needed and send heartbeat 247 | ackMsg <- atomically $ do 248 | maxAuthTick <- readTVar maxAuthTickTVar 249 | let newestTick = headTick + fromIntegral (length authInputss) - 1 250 | maxAuthTick' = 251 | if headTick <= maxAuthTick + 1 && maxAuthTick < newestTick 252 | then newestTick 253 | else maxAuthTick 254 | writeTVar maxAuthTickTVar maxAuthTick' 255 | return (Msg_Ack maxAuthTick') 256 | sendToServer ackMsg 257 | 258 | -- Save new auth inputs 259 | let newAuthTickHi = headTick + Tick (fromIntegral $ length authInputss) 260 | resMsg <- forM (zip [headTick ..] authInputss) $ \(tick, inputs) -> do 261 | atomically $ do 262 | authInputs <- readTVar authInputsTVar 263 | -- when (tickInt `mod` 100 == 0) (putStrLn $ "Received auth tick: " ++ show tickInt) 264 | case authInputs IM.!? fromIntegral tick of 265 | Just _ -> return $ Just $ "Received a duplicate Msg_AuthInput for " ++ show tick ++ ". Ignoring." 266 | Nothing -> do 267 | -- New auth inputs 268 | writeTVar authInputsTVar (IM.insert (fromIntegral tick) inputs authInputs) 269 | return (Just $ "Got auth-inputs for " ++ show tick) 270 | 271 | -- Save new hint inputs, Excluding my own! 272 | forM_ (zip [succ newAuthTickHi ..] hintInputss) $ \(tick, newHintinputs) -> 273 | atomically $ do 274 | myPlayerIdMay <- readTVar myPlayerIdTVar 275 | modifyTVar hintInputsTVar $ 276 | IM.alter 277 | ( \case 278 | Just oldHintinputs 279 | | Just myPlayerId <- myPlayerIdMay -> 280 | Just (M.restrictKeys oldHintinputs (S.singleton myPlayerId) <> newHintinputs <> oldHintinputs) 281 | _ -> Just newHintinputs 282 | ) 283 | (fromIntegral tick) 284 | 285 | return resMsg 286 | mapM_ debugStrLn (catMaybes resMsgs) 287 | Msg_HintInput tick playerId inputs -> do 288 | res <- atomically $ do 289 | hintInputs <- readTVar hintInputsTVar 290 | let hintInputsAtTick = fromMaybe M.empty (hintInputs IM.!? fromIntegral tick) 291 | writeTVar hintInputsTVar (IM.insert (fromIntegral tick) (M.insert playerId inputs hintInputsAtTick) hintInputs) 292 | return (Just $ "Got hint-inputs for " ++ show tick) 293 | mapM_ debugStrLn res 294 | 295 | -- Wait to be connected. 296 | myPlayerId <- atomically $ do 297 | myPlayerIdMay <- readTVar myPlayerIdTVar 298 | maybe retry return myPlayerIdMay 299 | 300 | -- Recently submitted inputs and their tick in reverse chronological order. 301 | recentSubmittedInputsTVar <- newTVarIO [(Tick 0, input0)] 302 | -- last returned auth world tick (inclusive) from the sampling function 303 | lastSampledAuthWorldTickTVar :: TVar Tick <- newTVarIO 0 304 | -- last returned predicted world from the sampling function 305 | lastSampledPredictedWorldTVar :: TVar world <- newTVarIO world0 306 | -- Is the client Stopped? 307 | stoppedTVar :: TVar Bool <- newTVarIO False 308 | 309 | return $ 310 | Client 311 | { clientPlayerId = myPlayerId 312 | , clientSample' = do 313 | stopped <- atomically $ readTVar stoppedTVar 314 | if stopped 315 | then do 316 | lastPredictedWorld <- atomically $ readTVar lastSampledPredictedWorldTVar 317 | return ([], lastPredictedWorld) 318 | else do 319 | -- TODO we're just resimulating from the last snapshot every 320 | -- time. We may be able to reuse past simulation data if 321 | -- snapshot / inputs haven't changed. 322 | 323 | -- Since we are sending inputs for tick 324 | -- estimateServerTickPlusLatencyPlusBuffer and we want to minimize 325 | -- perceived input latency, we should target that same tick 326 | targetTick <- estimateServerTickPlusLatencyPlusBuffer 327 | (inputs, hintInputs, startTickInt, startWorld) <- atomically $ do 328 | (startTickInt, startWorld) <- 329 | fromMaybe (error $ "No authoritative world found <= " ++ show targetTick) -- We have at least the initial world 330 | . IM.lookupLE (fromIntegral targetTick) 331 | <$> readTVar authWorldsTVar 332 | inputs <- readTVar authInputsTVar 333 | hintInputs <- readTVar hintInputsTVar 334 | return (inputs, hintInputs, startTickInt, startWorld) 335 | let startInputs = 336 | fromMaybe 337 | (error $ "Have auth world but no authoritative inputs at " ++ show startTick) -- We assume that we always have auth inputs on ticks where we have auth worlds. 338 | (IM.lookup startTickInt inputs) 339 | startTick = Tick (fromIntegral startTickInt) 340 | 341 | predict :: 342 | Int64 -> -- How many ticks of prediction to allow 343 | Tick -> -- Some tick i 344 | M.Map PlayerId input -> -- inputs at tick i 345 | world -> -- world at tick i if simulated 346 | Bool -> -- Is the world authoritative? 347 | IO world -- world at targetTick (or latest tick if predictionAllowance ran out) 348 | predict predictionAllowance tick tickInputs world isWAuth = case compare tick targetTick of 349 | LT -> do 350 | let tickNext = tick + 1 351 | 352 | inputsNextAuthMay = inputs IM.!? (fromIntegral tickNext) -- auth input 353 | isInputsNextAuth = isJust inputsNextAuthMay 354 | isWNextAuth = isWAuth && isInputsNextAuth 355 | if isWNextAuth || predictionAllowance > 0 356 | then do 357 | let inputsNextHintPart = fromMaybe M.empty (hintInputs IM.!? (fromIntegral tickNext)) -- partial hint inputs 358 | inputsNextHintFilled = inputsNextHintPart `M.union` tickInputs -- hint input (filled with previous input) 359 | inputsNext = fromMaybe inputsNextHintFilled inputsNextAuthMay 360 | wNext = stepOneTick inputsNext tickNext world 361 | 362 | pruneOldAuthWorlds = True 363 | -- TODO ^^ in the future we may wan to keep all auth 364 | -- worlds to implement a time traveling debugger 365 | when isWNextAuth $ 366 | atomically $ do 367 | modifyTVar authWorldsTVar (IM.insert (fromIntegral tickNext) wNext) 368 | when pruneOldAuthWorlds $ do 369 | -- We keep all new authworlds as we used them in 370 | -- `newAuthWorlds` and ultimately return them on 371 | -- sample. 372 | lastSampledAuthWorldTick <- readTVar lastSampledAuthWorldTickTVar 373 | modifyTVar authWorldsTVar (snd . IM.split (fromIntegral lastSampledAuthWorldTick)) 374 | 375 | let predictionAllowance' = if isWNextAuth then predictionAllowance else predictionAllowance - 1 376 | predict predictionAllowance' tickNext inputsNext wNext isWNextAuth 377 | else return world 378 | EQ -> return world 379 | GT -> error "Impossible! simulated past target tick!" 380 | 381 | -- If very behind the server, we want to do 0 prediction 382 | maxAuthTick <- atomically $ readTVar maxAuthTickTVar 383 | let predictionAllowance = 384 | if targetTick - maxAuthTick > Tick (fromIntegral $ ccResyncThresholdTicks clientConfig) 385 | then 0 386 | else fromIntegral (ccMaxPredictionTicks clientConfig) 387 | 388 | predictedTargetW <- predict predictionAllowance startTick startInputs startWorld True 389 | atomically $ writeTVar lastSampledPredictedWorldTVar predictedTargetW 390 | newAuthWorlds :: [world] <- atomically $ do 391 | lastSampledAuthWorldTick <- readTVar lastSampledAuthWorldTickTVar 392 | authWorlds <- readTVar authWorldsTVar 393 | let latestAuthWorldTick = Tick $ fromIntegral $ fst $ IM.findMax authWorlds 394 | writeTVar lastSampledAuthWorldTickTVar latestAuthWorldTick 395 | return ((authWorlds IM.!) . fromIntegral <$> [lastSampledAuthWorldTick + 1 .. latestAuthWorldTick]) 396 | 397 | return (newAuthWorlds, predictedTargetW) 398 | , clientSetInput = 399 | -- TODO We can send (non-auth) inputs p2p! 400 | 401 | -- TODO this mechanism minimizes latency when `targetTick > lastTick` by 402 | -- sending the input to the server immediately, but when `targetTick <= 403 | -- lastTick`, then the input will be ghosted! 404 | \newInput -> do 405 | stopped <- atomically $ readTVar stoppedTVar 406 | when (not stopped) $ do 407 | -- We submit events as soon as we expect the server to be on a future 408 | -- tick. Else we just store the new input. 409 | targetTick <- estimateServerTickPlusLatencyPlusBufferPlus (ccFixedInputLatency clientConfig) 410 | join $ 411 | atomically $ do 412 | lastTick <- 413 | ( \case 414 | [] -> Tick 0 415 | (t, _) : _ -> t 416 | ) 417 | <$> readTVar recentSubmittedInputsTVar 418 | if targetTick > lastTick 419 | then do 420 | -- Store our own inputs as a hint so we get 0 latency. This is 421 | -- only a hint and not authoritative as it's still possible that 422 | -- submitted inputs are dropped or rejected by the server. If 423 | -- we've jumped a few ticks forward than we keep we don't attempt 424 | -- to submit inputs to "fill in the gap". We assume constant as 425 | -- the server and other clients predicted those inputs as constant 426 | -- anyway. 427 | modifyTVar hintInputsTVar $ 428 | IM.alter 429 | (Just . M.insert myPlayerId newInput . fromMaybe M.empty) 430 | (fromIntegral targetTick) 431 | 432 | modifyTVar recentSubmittedInputsTVar $ 433 | take (ccSubmitInputDuplication clientConfig) 434 | . ((targetTick, newInput) :) 435 | inputsToSubmit <- readTVar recentSubmittedInputsTVar 436 | return (sendToServer (Msg_SubmitInput inputsToSubmit)) 437 | else pure (return ()) 438 | , clientStop = do 439 | stopped <- atomically (readTVar stoppedTVar) 440 | when (not stopped) $ do 441 | killThread msgLoopTid 442 | killThread heartbeatTid 443 | atomically $ do 444 | writeTVar stoppedTVar True 445 | } 446 | --------------------------------------------------------------------------------