fix communication

src-client/Client/Communication.hs

@@ -20,12 +20,8 @@ import Data.IORef
 
 import Data.UUID
 
-import qualified Data.Vector.Storable as VS
-
 import Foreign hiding (void)
 
-import Graphics.Vty as Vty
-
 import Network.Socket
 
 import System.Posix.Signals
@@ -46,11 +42,10 @@ connectSocket path = do
 
 -- | Sends a specified message through given socket to the server
 sendMessage
-  :: StateContainer
+  :: ClientMessage
-  -> ClientMessage
   -> Socket
   -> IO ()
-sendMessage st msg sock = do
+sendMessage msg sock = do
   let msgJson = A.encode msg
       msgList = B.unpack $ B.toStrict msgJson
   ptr <- newArray msgList
@@ -79,9 +74,7 @@ handleMessage ServerQuit = do
 handleMessage (Ping id') = do
   cid <- asks rcClientUUID
   sock <- asks rcSocket
-  st <- get
   liftIO $ sendMessage
-    st
     ( ClientMessage
       cid
       (Pong id')
@@ -106,12 +99,7 @@ gracefulExit
   -> IO ()
 gracefulExit st reason = do
   liftIO $ putStrLn reason
-  let stateCont = scClientState st
+  writeIORef (scStopper st) True
-  liftIO $ STM.atomically $ do
-    stateContainer <- STM.readTMVar stateCont
-    void $ STM.swapTMVar stateCont $ stateContainer
-      { clientStop = True
-      }
 
 receiveMessage
   :: Socket
@@ -148,10 +136,12 @@ terminateGameOnSigint
   :: IORef Bool
   -> Game ()
 terminateGameOnSigint stopper = do
+  rc <- ask
   void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
       putStrLn "receiveMessage: SIGINT caught, terminating…"
+      liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc)
       atomicWriteIORef stopper True
       -- Vty.shutdown (clientVty currentState)
       -- Raise SIGINT again so it does not get blocked
@@ -160,10 +150,9 @@ terminateGameOnSigint stopper = do
     Nothing
 
 partingMessage
-  :: StateContainer
+  :: UUID
-  -> UUID
   -> Socket
   -> IO ()
-partingMessage st clientId sock = do
+partingMessage clientId sock = do
-  sendMessage st (ClientMessage clientId ClientQuit) sock
+  putStrLn "sending parting message to server…"
-  -- close sock
+  sendMessage (ClientMessage clientId ClientQuit) sock

src-client/Client/Game.hs

@@ -1,16 +1,10 @@
 module Client.Game where
 
-import Control.Concurrent
-
-import qualified Control.Concurrent.STM as STM
-
-import Control.Monad
-
 import Control.Monad.Loops
 
 import Control.Monad.RWS
 
-import Data.IORef (IORef, readIORef)
+import Data.IORef (readIORef)
 
 import Graphics.Vty
 
@@ -23,23 +17,21 @@ import Client.Types
 import Library.Types
 
 runGame 
-  :: IORef Bool
+  :: Game ()
-  -> Game ()
+runGame = do
-runGame stopper = do
   sock <- asks rcSocket
   queue <- asks rcQueue
   clientId <- asks rcClientUUID
   st <- get
   -- recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
-  liftIO $ sendMessage st(ClientMessage clientId ClientReady) sock
+  liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
   whileM_
-    (liftIO (not <$> readIORef stopper))
+    (liftIO (not <$> readIORef (scStopper st)))
     (do
       liftIO $ receiveMessage sock queue st
       handleMessages
       -- draw
     )
-  liftIO $ partingMessage st clientId sock
   -- liftIO $ killThread recvThread
 
 handleEvent

src-client/Client/Types.hs

@@ -6,6 +6,8 @@ import Control.Exception (Exception)
 
 import Control.Monad.RWS
 
+import Data.IORef (IORef)
+
 import Data.UUID
 
 import Network.Socket
@@ -37,6 +39,7 @@ data StateContainer = StateContainer
   { scWizard      :: Wizard
   , scClientState :: STM.TMVar ClientState
   , scMapSlice    :: MapSlice
+  , scStopper     :: IORef Bool
   }
 
 type Game = RWST ReaderContainer String StateContainer IO

src-client/Main.hs

@@ -14,8 +14,6 @@ import qualified Data.Matrix as M
 
 import Graphics.Vty
 
-import Network.Socket (close)
-
 import Options.Applicative
 
 -- internal imports
@@ -39,9 +37,9 @@ main = do
 
 
   -- threadDelay $ 1 * 10 ^ 6
-  mockClientState <- STM.newTMVarIO (ClientState undefined False False)
+  mockClientState <- STM.newTMVarIO (ClientState undefined False)
-  let mockState = StateContainer undefined mockClientState undefined
+  let mockState = StateContainer undefined mockClientState undefined undefined
-  sendMessage mockState (IdRequest) sock
+  sendMessage IdRequest sock
   receiveMessage sock queue mockState
   awaitResponse queue 1
   clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
@@ -53,7 +51,7 @@ main = do
   threadDelay $ 5 * 10 ^ 6
 
 
-  sendMessage mockState (ClientMessage clientId ClientRequestWizard) sock
+  sendMessage (ClientMessage clientId ClientRequestWizard) sock
   -- threadDelay $ 1 * 10 ^ 6
   receiveMessage sock queue mockState
   awaitResponse queue 1
@@ -67,17 +65,17 @@ main = do
   -- shut down graphical interface for now
   -- shutdown vty
 
-  clientState <- STM.newTMVarIO (ClientState undefined False False)
+  stopper <- newIORef False
+  clientState <- STM.newTMVarIO (ClientState undefined False)
   let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
   let initRead = ReaderContainer sock clientId queue
-      initState = StateContainer (initWizard playerWizard) clientState initSlice
+      initState = StateContainer (initWizard playerWizard) clientState initSlice stopper
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
-  stopper <- newIORef False
   void $ execRWST
     (do
       terminateGameOnSigint stopper
-      runGame stopper
+      runGame
     )
     initRead
     initState

src-lib/Library/Types/Map.hs

@@ -16,7 +16,6 @@ import Data.Aeson (ToJSON, FromJSON)
 data ClientState = ClientState
   { clientVty      :: Vty  -- ^ Context object for graphics
   , clientGameOver :: Bool -- ^ client game over (contestant died)
-  , clientStop     :: Bool -- ^ client shutdown
   }
 
 -- | Type synonym for the Map. Translates to a Matrix of 'Tile's

src-server/Server/Communication.hs

@@ -62,13 +62,13 @@ terminateGameOnSigint
   :: Game ()
 terminateGameOnSigint = do
   sock <- asks rcMainSocket
-  clientList <- gets scClientSockets
-  clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
   serverState <- gets scServerState
+  clientList <- gets scClientSockets
   void $ liftIO $ installHandler
     sigINT
     (CatchOnce $ do
       putStrLn "SIGINT caught, terminating…"
+      clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
       disconnectClients clientList clients
       close sock
       st <- STM.atomically $ STM.readTMVar serverState
@@ -83,16 +83,19 @@ disconnectClients
   :: STM.TMVar [ClientComms]
   -> [ClientComms]
   -> IO ()
-disconnectClients clientList = mapM_
+disconnectClients clientList clients = do
-  (\client -> do
+  putStrLn "server shutting down. Notifying all clients…"
-    maybe
+  mapM_
-      (pure ())
+    (\client -> do
-      (\uuid -> do
+      maybe
-        sendMessage ServerQuit uuid clientList
+        (pure ())
-        dropClient clientList (ccSocket client)
+        (\uuid -> do
-      )
+          sendMessage ServerQuit uuid clientList
-      (ccUUID client)
+          dropClient clientList (ccSocket client)
-  )
+        )
+        (ccUUID client)
+    )
+    clients
 
 -- | Drops the client from internal management and closes its socket, if still present.
 dropClient
@@ -126,8 +129,8 @@ processRequests = do
   where
     acceptConnection mainSocket socketList queue st = do
       putStrLn "Ready for new connection requests…"
-      esock <- try $ accept mainSocket
+      eSock <- try $ accept mainSocket
-      case esock of
+      case eSock of
         Left (_ :: SomeException) ->
           putStrLn "Main socket vanished!"
         Right (clientSock, _) -> do
@@ -135,7 +138,7 @@ processRequests = do
             receiveMessage clientSock queue socketList
           liftIO $ STM.atomically $ do
             list <- STM.takeTMVar socketList
-            STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
+            STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list)
           putStrLn "accepted new connection"
           abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
           unless abortCondition $
@@ -150,7 +153,7 @@ sendMessage
   -> IO ()
 sendMessage msg uuid clientList = do
   clients <- STM.atomically $ STM.readTMVar clientList
-  let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
+  let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
       msgJson = A.encode msg
       msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
   putStrLn $ "Sending: " <> B8.unpack msgJson
@@ -159,9 +162,16 @@ sendMessage msg uuid clientList = do
     (\sock ->
       VS.unsafeWith
         msgVector
-        (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
+        (\ptr -> do
+          eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
+          case eResult of
+            Left (_ :: IOException) ->
+              putStrLn $ "cant reach client " <> show uuid
+            Right _ ->
+              pure ()
+        )
       )
-    msock
+    mSock
 
 -- | handle received messages
 handleMessages :: Game ()
@@ -177,7 +187,6 @@ handleMessages = do
         pure []
       else
         STM.flushTQueue queue
-    unless (null msgs) $ putStrLn "GET"
     void $ do
       mapM_
         (handleMessage serverState readerContainer)
@@ -191,11 +200,11 @@ receiveMessage
   -> IO ()
 receiveMessage sock queue clientList = do
   let maxBufferLength = 4096
-  mmsg <- do
+  mMsg <- do
     ptr <- mallocArray maxBufferLength
-    ebufferLength <-
+    eBufferLength <-
       try $ recvBuf sock ptr maxBufferLength
-    bufferLength <- case ebufferLength of
+    bufferLength <- case eBufferLength of
       Left (_ :: IOException) -> do
         putStrLn "Socket vanished, cleaning up…"
         dropClient clientList sock
@@ -212,11 +221,10 @@ receiveMessage sock queue clientList = do
   maybe
     (pure ())
     (\msg -> do
-      putStrLn "PUT"
       liftIO $ STM.atomically $ STM.writeTQueue queue msg
       -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
     )
-    mmsg
+    mMsg
 
 -- | function for translating 'ClientMessage's into server actions
 handleMessage
@@ -232,10 +240,10 @@ handleMessage stateContainer readerContainer msg = do
     IdRequest                      -> do
       clientId <- nextRandom
       let clientIdx = findIndex (isNothing . ccUUID) clients
-      let clientSock = ccSocket $ clients !! fromJust clientIdx
+          clientSock = ccSocket $ clients !! fromJust clientIdx
-      let newClients = map
+          newClients = map
-            (\old@(ClientComms muuid oldClientSock _) ->
+            (\old@(ClientComms mUUID oldClientSock _) ->
-              if oldClientSock == clientSock && isNothing muuid
+              if oldClientSock == clientSock && isNothing mUUID
               then
                 old
                   { ccUUID = Just clientId
@@ -250,15 +258,9 @@ handleMessage stateContainer readerContainer msg = do
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
-          putStrLn $ "removing client " <> show clientId
+          putStrLn $ "client " <> show clientId <> " has quit the game"
-          let newClients = filter (\a -> ccUUID a /= Just clientId) clients
+          let client = find (\a -> ccUUID a == Just clientId) clients
-              client = find (\a -> ccUUID a == Just clientId) clients
+          dropClient clientList (ccSocket $ fromJust client)
-          STM.atomically $ do
-            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
-            let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
-            void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
-            void $ STM.swapTMVar clientList newClients
-          close (ccSocket $ fromJust client)
         ClientRequestWizard -> do
           putStrLn "initializing new wizard"
           let arena = rcMap readerContainer
@@ -273,28 +275,32 @@ handleMessage stateContainer readerContainer msg = do
           sendMessage (ProvideInitialWizard freshWizard) clientId clientList
         ClientReady -> do
           putStrLn $ "client " <> show clientId <> " is ready!"
+          now <- getCurrentTime
           STM.atomically $ do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             let (thisPlayers, otherPlayers) =
                   partition (\p -> playerId p == clientId) currentPlayers
             unless (null thisPlayers) $
               void $ STM.swapTMVar (scPlayers stateContainer) $
-                (head thisPlayers) {playerReady = True} : otherPlayers
+                (head thisPlayers)
+                  { playerReady = True
+                  , playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
+                  }
+                  : otherPlayers
         Pong uuid -> do
           let mclient = find (\c -> ccUUID c == Just clientId) clients
           maybe
             (putStrLn $ "Who is " <> show uuid <> "?")
-            (\client -> do
+            (\_ -> do
-              mplayer <- STM.atomically $ do
+              mPlayer <- STM.atomically $ do
                 players <- STM.readTMVar (scPlayers stateContainer)
                 pure $ find (\p -> playerId p == clientId) players
               maybe
                 (pure ())
                 (\player ->
                   if snd (playerLastPong player) /= uuid
-                  then do
+                  then
-                    putStrLn $ "dropping client " <> show clientId
+                    putStrLn $ "Pong ID mismatch from " <> show clientId
-                    dropClient clientList (ccSocket client)
                   else do
                     now <- getCurrentTime
                     STM.atomically$ do
@@ -305,7 +311,7 @@ handleMessage stateContainer readerContainer msg = do
                             }
                       void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
                 )
-                mplayer
+                mPlayer
             )
             mclient
 
@@ -330,7 +336,7 @@ sendPings = do
             put stateContainer
           else do
             random <- liftIO nextRandom
-            let newPong = (now, random)
+            let newPong = (lastPongTime, random)
             liftIO $ sendMessage
               ( Ping random
               )