begin synchronisation primitives

src-server/Server/Communication.hs

@@ -26,6 +26,8 @@ import Data.Maybe
 import Data.UUID hiding (null)
 import Data.UUID.V4
 
+import Data.Time
+
 import qualified Data.Vector.Storable as VS
 
 import Foreign hiding (void)
@@ -78,12 +80,15 @@ terminateGameOnSigint path = do
       -- raiseSignal sigINT
     )
     Nothing
-  where
+
-    disconnectClients = mapM_
+disconnectClients
-      (\(_, clientSocket) -> do
+  :: [Client]
-        sendMessage ServerQuit clientSocket
+  -> IO ()
-        close clientSocket
+disconnectClients = mapM_
-      )
+  (\(_, clientSocket) -> do
+    sendMessage ServerQuit clientSocket
+    close clientSocket
+  )
 
 -- | Process incoming connection requests
 processRequests :: Game ()
@@ -178,11 +183,11 @@ handleMessage stateContainer readerContainer msg = do
   case msg of
     IdRequest                      -> do
       clientId <- nextRandom
-      let clientIdx = findIndex (\a -> fst a == Nothing) clients
+      let clientIdx = findIndex (isNothing . fst) clients
       let clientSock = snd $ clients !! fromJust clientIdx
       let newClients = map
             (\old@(muuid, oldClientSock) ->
-              if oldClientSock == clientSock && muuid == Nothing
+              if oldClientSock == clientSock && isNothing muuid
               then
                 (Just clientId, clientSock)
               else
@@ -224,49 +229,29 @@ handleMessage stateContainer readerContainer msg = do
                 (head thisPlayers) {playerReady = True} : otherPlayers
         _          -> pure ()
 
-sendUpdates :: Game ()
+sendPings :: Game ()
-sendUpdates = do
+sendPings = do
+  now <- liftIO getCurrentTime
   tileMap <- asks rcMap
+  maxTimeout <- asks rcClientMaxTimeout
+  framesPerPing <- asks rcFramesPerPing
+  fps <- asks rcFPS
   stateContainer <- get
   players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
   sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
   mapM_
-    (\(Player playerId wizard@(Wizard {..}) readiness) -> do
+    (\(Player playerId (Wizard {}) readiness lastPong) -> do
-      when readiness $ do
+      let timeDiff = realToFrac $ diffUTCTime now lastPong
-        let V2 wr wc = wizardPos
+      when (readiness && timeDiff > (framesPerPing * recip fps)) $ do
-            subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
+        let clientSock = fromJust (lookup (Just playerId) sockets)
-            leftBound = wizardRot + (pi / 4)
+        if timeDiff > maxTimeout
-            rightBound = wizardRot - (pi / 4)
+        then
-            leftLine row = cos leftBound * row
+          liftIO $ disconnectClients [clientSock]
-            rightLine row = sin rightBound * row
+        else do
-            correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
+          random <- liftIO $ nextRandom
-              then floor
+          liftIO $ sendMessage
-              else ceiling
+            ( Ping random
-            correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
+            )
-              then ceiling
+            clientSock
-              else floor
-            viewMatrix = M.fromList 9 9 $ map
-              (\(qr, qc) ->
-                if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr))
-                    && qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr))
-                then
-                  M.safeGet qr qc tileMap
-                else
-                  Nothing
-              )
-              subCoords
-            clientSock = fromJust $ lookup (Just playerId) sockets
-        -- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
-        -- liftIO $ print initViewMatrix
-        liftIO $ sendMessage
-          (TickUpdate
-            { tuWizard   = wizard
-            , tuMapSlice = MapSlice
-              { msViewMap  = viewMatrix
-              , msContents = []
-              }
-            }
-          )
-          clientSock
     )
     players

src-server/Server/Types.hs

@@ -27,6 +27,8 @@ data Settings = Settings
   , setMapColumns         :: Int
   , setSpawnerProbability :: Float
   , setFPS                :: Int
+  , setClientMaxTimeout   :: Float
+  , setFramesPerPing      :: Int
   }
   deriving (Show, Generic)
 
@@ -46,9 +48,11 @@ options = Options
     )
 
 data ReaderContainer = ReaderContainer
-  { rcMap        :: ServerMap
+  { rcMap              :: ServerMap
-  , rcFPS        :: Int
+  , rcFPS              :: Int
-  , rcMainSocket :: Socket
+  , rcFramesPerPing    :: Int
+  , rcClientMaxTimeout :: Float
+  , rcMainSocket       :: Socket
   }
   deriving (Eq, Show)
 
@@ -62,9 +66,10 @@ data StateContainer = StateContainer
   }
 
 data Player = Player
-  { playerId     :: UUID
+  { playerId       :: UUID
-  , playerWizard :: Wizard
+  , playerWizard   :: Wizard
-  , playerReady  :: Bool
+  , playerReady    :: Bool
+  , playerLastPong :: UTCTime
   }
   deriving (Eq, Show)