first actual message passing

src-client/Main.hs

@@ -1,7 +1,12 @@
+{-# LANGUAGE LambdaCase #-}
 module Main where
 
 import Control.Concurrent (threadDelay)
 
+import Data.Aeson as A
+
+import qualified Data.ByteString.Lazy.Char8 as B8
+
 import Options.Applicative
 
 import System.IO
@@ -11,18 +16,33 @@ import System.IO
 import Client.Communication
 import Client.Types
 
+import Library.Types
+
 main :: IO ()
 main = do
   putStrLn "Hello, Arena!"
   (Options socketLocation) <- execParser opts
   putStrLn $ "connecting to Socket " <> socketLocation
   handle <- connectSocket socketLocation
+  message <- hGetContents handle
+  let mJsonMessage = decode' $ B8.pack message :: Maybe ServerMessage
+      errMsg = (error $ "unexpected message from Server: " <> message)
+      uuid   = maybe
+        errMsg
+        (\case
+          (AcceptClient uuid) -> uuid
+          _ -> errMsg
+        )
+        mJsonMessage
+      -- reader = ReaderContainer handle uuid
+  putStrLn $ "received uuid " <> show uuid
   -- mock communication code
   hPutStrLn handle "meow!"
   hFlush handle
   threadDelay $ 5 * 10 ^ 6
   hPutStrLn handle "Goodbye!"
   hFlush handle
+  threadDelay $ 5 * 10 ^ 6
   -- end mock
   where
     opts = info (options <**> helper)

src-lib/Library/Types.hs

@@ -1,9 +1,14 @@
-module Library.Types where
+module Library.Types
+  ( module T
+  , module Library.Types
+  ) where
 
 import Data.Matrix
 import Graphics.Vty
 import Linear
 
+import Library.Types.Communication as T
+
 -- | Just a type synonym for any kind of position. Translates to a 2D vector
 type Position = V2 Float
 

src-server/Server/Communication.hs

@@ -11,6 +11,12 @@ import Control.Monad.IO.Class
 
 import Control.Monad.RWS.Strict
 
+import qualified Data.Aeson as A
+
+import qualified Data.ByteString as B
+
+import Data.UUID.V4
+
 import Network.Socket as Net
 
 import System.IO
@@ -19,6 +25,8 @@ import System.Posix.Signals
 
 -- internal imports
 
+import Library.Types
+
 import Server.Types
 import Server.Util
 
@@ -74,11 +82,27 @@ processRequests = do
     acceptConnection mainSocket socketList = do
       (clientSock, _) <- accept mainSocket
       putStrLn "accepted new connection"
+      uuid <- nextRandom
+      putStrLn $ "accepting client with uuid " <> show uuid
+      sendMessage (AcceptClient uuid) clientSock
       liftIO $ STM.atomically $ do
         list <- STM.takeTMVar socketList
         STM.putTMVar socketList ((clientSock, Nothing) : list)
       acceptConnection mainSocket socketList
 
+-- | Sends a specified message through given socket to the client
+sendMessage
+  :: ServerMessage
+  -> Socket
+  -> IO ()
+sendMessage msg sock = do
+  connectionHandle <- socketToHandle sock WriteMode
+  hSetBuffering connectionHandle (BlockBuffering Nothing)
+  let msgJson = A.encode msg
+  B.hPutStr connectionHandle $ B.toStrict msgJson
+  hFlush connectionHandle
+  hClose connectionHandle
+
 -- | process incoming messages from clients
 processMessages :: Game ()
 processMessages = do

wizard-wipeout.cabal

@@ -25,6 +25,7 @@ library
                     , linear
                     , matrix
                     , random
+                    , uuid
                     , vty
     hs-source-dirs:   src-lib
     default-language: GHC2021
@@ -36,6 +37,8 @@ executable wizard-wipeout-client
                       Client.Types
     -- other-extensions:
     build-depends:    base ^>=4.17.2.1
+                    , aeson
+                    , bytestring
                     , monad-loops
                     , mtl
                     , network
@@ -70,6 +73,7 @@ executable wizard-wipeout-server
                     , random
                     , stm
                     , unix
+                    , uuid
                     , wizard-wipeout
                     , yaml
     hs-source-dirs:   src-server