more client-server communication

configuration.yaml

@@ -2,4 +2,4 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 40
 setMapColumns         : 40
 setSpawnerProbability : 0.01
-setFPS                : 5
+setFPS                : 30

src-client/Client/Communication.hs

@@ -1,8 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 module Client.Communication where
 
-import Control.Concurrent (threadDelay)
-
 import qualified Control.Concurrent.STM as STM
 
 import Control.Monad.RWS
@@ -48,6 +47,43 @@ sendMessage msg sock = do
     msgVector
     (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
 
+handleMessages
+  :: Game ()
+handleMessages = do
+  sock <- asks rcSocket
+  queue <- asks rcQueue
+  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
+  mapM_
+    handleMessage
+    msgs
+
+handleMessage
+  :: ServerMessage
+  -> Game ()
+handleMessage ServerQuit = do
+  state <- get
+  let stateCont = scClientState state
+  liftIO $ STM.atomically $ do
+    state <- STM.readTMVar stateCont
+    void $ STM.swapTMVar stateCont $ state
+      { clientStop = True
+      }
+  put $ state
+    { scClientState = stateCont
+    }
+  liftIO $ putStrLn "Quitting due to server shutdown"
+
+handleMessage (TickUpdate slice wizard) = do
+  modify' (\state@(StateContainer {..}) ->
+    state
+      { scWizard   = wizard
+      , scMapSlice = slice
+      }
+    )
+
+handleMessage x =
+  liftIO $ putStrLn $ "received unexpected message from server: " <> show x
+
 receiveMessage
   :: Socket
   -> STM.TQueue ServerMessage

src-client/Client/Game.hs

@@ -0,0 +1,23 @@
+module Client.Game where
+
+import qualified Control.Concurrent.STM as STM
+
+import Control.Monad.Loops
+
+import Control.Monad.RWS
+
+-- internal imports
+
+import Client.Communication
+import Client.Types
+
+import Library.Types
+
+runGame :: Game ()
+runGame = do
+  handleMessages
+  whileM_
+    (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
+    (do
+      pure ()
+    )

src-client/Client/Types.hs

@@ -28,11 +28,13 @@ options = Options
 data ReaderContainer = ReaderContainer
   { rcSocket     :: Socket
   , rcClientUUID :: UUID
+  , rcQueue      :: STM.TQueue ServerMessage
   }
 
 data StateContainer = StateContainer
   { scWizard      :: Wizard
   , scClientState :: STM.TMVar ClientState
+  , scMapSlice    :: MapSlice
   }
 
 type Game = RWST ReaderContainer String StateContainer IO

src-client/Main.hs

@@ -13,6 +13,8 @@ import Control.Monad.Loops
 
 import Control.Monad.RWS
 
+import qualified Data.Matrix as M
+
 import Graphics.Vty
 
 import Options.Applicative
@@ -20,6 +22,7 @@ import Options.Applicative
 -- internal imports
 
 import Client.Communication
+import Client.Game
 import Client.Types
 
 import Library.Types
@@ -63,16 +66,15 @@ main = do
   shutdown vty
 
   clientState <- STM.newTMVarIO (ClientState vty False False)
-  let initRead = ReaderContainer sock clientId
-      initState = StateContainer (initWizard playerWizard) clientState
+  let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
+  let initRead = ReaderContainer sock clientId queue
+      initState = StateContainer (initWizard playerWizard) clientState initSlice
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
   void $ execRWST
     (do
       terminateGameOnSigint
-      whileM_
-        (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
-        (pure ())
+      runGame
     )
     initRead
     initState

src-lib/Library/Types/Map.hs

@@ -60,7 +60,6 @@ data SpawnerState
 
 data MapSlice = MapSlice
   { msViewMap    :: ClientMap
-  , msViewOffset :: Position
   , msContents   :: [Effigy]
   }
   deriving (Eq, Show, Generic)

src-server/Main.hs

@@ -63,7 +63,7 @@ main = do
         )
         initRead
         initState
-      removeIfExists setSocketPath
+      -- removeIfExists setSocketPath
       putStrLn "bye bye"
   where
     opts = info (options <**> helper)

src-server/Server/Communication.hs

@@ -69,10 +69,10 @@ terminateGameOnSigint path = do
     sigINT
     (CatchOnce $ do
       putStrLn "SIGINT caught, terminating…"
-      void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
       disconnectClients clients
       close sock
       removeIfExists path
+      void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
       -- Raise SIGINT again so it does not get blocked
       -- raiseSignal sigINT
     )
@@ -108,7 +108,7 @@ sendMessage
 sendMessage msg sock = do
   let msgJson = A.encode msg
       msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
-  putStrLn $ "sending: " <> B8.unpack msgJson
+  -- putStrLn $ "sending: " <> B8.unpack msgJson
   VS.unsafeWith
     msgVector
     (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
@@ -217,6 +217,7 @@ sendUpdates = do
   tileMap <- asks rcMap
   stateContainer <- get
   players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
+  sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
   mapM_
     (\(player@(Player playerId wizard@(Wizard {..}))) -> do
       let V2 wr wc = wizardPos
@@ -231,7 +232,7 @@ sendUpdates = do
           correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
             then ceiling
             else floor
-          initViewMatrix = M.fromList 9 9 $ map
+          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))
@@ -241,7 +242,18 @@ sendUpdates = do
                 Nothing
             )
             subCoords
+          clientSock = fromJust $ lookup (Just playerId) sockets
       -- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
-      liftIO $ print initViewMatrix
+      -- liftIO $ print initViewMatrix
+      liftIO $ sendMessage
+        (TickUpdate
+          { tuWizard   = wizard
+          , tuMapSlice = MapSlice
+            { msViewMap  = viewMatrix
+            , msContents = []
+            }
+          }
+        )
+        clientSock
     )
     players

src-server/Server/Game.hs

@@ -38,13 +38,13 @@ runGame = do
       handleMessages
       updateSpawners delta
       updateWizards delta
-      sendUpdates
       modify'
         (\s -> s
           { scServerLastTick = now
           }
         )
       fps <- asks rcFPS
+      sendUpdates
       let remainingTime = recip (fromIntegral fps) - delta
       when (remainingTime > 0) $
         liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6

wizard-wipeout.cabal

@@ -36,11 +36,13 @@ executable wizard-wipeout-client
     import:           warnings
     main-is:          Main.hs
     other-modules:    Client.Communication
+                      Client.Game
                       Client.Types
     -- other-extensions:
     build-depends:    base ^>=4.17.2.1
                     , aeson
                     , bytestring
+                    , matrix
                     , monad-loops
                     , mtl
                     , network