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,8 +80,11 @@ terminateGameOnSigint path = do
       -- raiseSignal sigINT
     )
     Nothing
-  where
-    disconnectClients = mapM_
+
+disconnectClients
+  :: [Client]
+  -> IO ()
+disconnectClients = mapM_
   (\(_, clientSocket) -> do
     sendMessage ServerQuit clientSocket
     close clientSocket
@@ -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,48 +229,28 @@ handleMessage stateContainer readerContainer msg = do
                 (head thisPlayers) {playerReady = True} : otherPlayers
         _          -> pure ()
 
-sendUpdates :: Game ()
-sendUpdates = do
+sendPings :: Game ()
+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
-      when readiness $ do
-        let V2 wr wc = wizardPos
-            subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
-            leftBound = wizardRot + (pi / 4)
-            rightBound = wizardRot - (pi / 4)
-            leftLine row = cos leftBound * row
-            rightLine row = sin rightBound * row
-            correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
-              then floor
-              else ceiling
-            correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
-              then ceiling
-              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))
+    (\(Player playerId (Wizard {}) readiness lastPong) -> do
+      let timeDiff = realToFrac $ diffUTCTime now lastPong
+      when (readiness && timeDiff > (framesPerPing * recip fps)) $ do
+        let clientSock = fromJust (lookup (Just playerId) sockets)
+        if timeDiff > maxTimeout
         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 $ disconnectClients [clientSock]
+        else do
+          random <- liftIO $ nextRandom
           liftIO $ sendMessage
-          (TickUpdate
-            { tuWizard   = wizard
-            , tuMapSlice = MapSlice
-              { msViewMap  = viewMatrix
-              , msContents = []
-              }
-            }
+            ( Ping random
             )
             clientSock
     )

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)
 
@@ -48,6 +50,8 @@ options = Options
 data ReaderContainer = ReaderContainer
   { rcMap              :: ServerMap
   , rcFPS              :: Int
+  , rcFramesPerPing    :: Int
+  , rcClientMaxTimeout :: Float
   , rcMainSocket       :: Socket
   }
   deriving (Eq, Show)
@@ -65,6 +69,7 @@ data Player = Player
   { playerId       :: UUID
   , playerWizard   :: Wizard
   , playerReady    :: Bool
+  , playerLastPong :: UTCTime
   }
   deriving (Eq, Show)