first actual message passing

This commit is contained in:
nek0 2023-12-10 17:00:50 +01:00
parent 03679ef1fa
commit aa1805ce19
4 changed files with 54 additions and 1 deletions

View file

@ -1,7 +1,12 @@
{-# LANGUAGE LambdaCase #-}
module Main where module Main where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as B8
import Options.Applicative import Options.Applicative
import System.IO import System.IO
@ -11,18 +16,33 @@ import System.IO
import Client.Communication import Client.Communication
import Client.Types import Client.Types
import Library.Types
main :: IO () main :: IO ()
main = do main = do
putStrLn "Hello, Arena!" putStrLn "Hello, Arena!"
(Options socketLocation) <- execParser opts (Options socketLocation) <- execParser opts
putStrLn $ "connecting to Socket " <> socketLocation putStrLn $ "connecting to Socket " <> socketLocation
handle <- connectSocket 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 -- mock communication code
hPutStrLn handle "meow!" hPutStrLn handle "meow!"
hFlush handle hFlush handle
threadDelay $ 5 * 10 ^ 6 threadDelay $ 5 * 10 ^ 6
hPutStrLn handle "Goodbye!" hPutStrLn handle "Goodbye!"
hFlush handle hFlush handle
threadDelay $ 5 * 10 ^ 6
-- end mock -- end mock
where where
opts = info (options <**> helper) opts = info (options <**> helper)

View file

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

View file

@ -11,6 +11,12 @@ import Control.Monad.IO.Class
import Control.Monad.RWS.Strict 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 Network.Socket as Net
import System.IO import System.IO
@ -19,6 +25,8 @@ import System.Posix.Signals
-- internal imports -- internal imports
import Library.Types
import Server.Types import Server.Types
import Server.Util import Server.Util
@ -74,11 +82,27 @@ processRequests = do
acceptConnection mainSocket socketList = do acceptConnection mainSocket socketList = do
(clientSock, _) <- accept mainSocket (clientSock, _) <- accept mainSocket
putStrLn "accepted new connection" putStrLn "accepted new connection"
uuid <- nextRandom
putStrLn $ "accepting client with uuid " <> show uuid
sendMessage (AcceptClient uuid) clientSock
liftIO $ STM.atomically $ do liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList list <- STM.takeTMVar socketList
STM.putTMVar socketList ((clientSock, Nothing) : list) STM.putTMVar socketList ((clientSock, Nothing) : list)
acceptConnection mainSocket socketList 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 -- | process incoming messages from clients
processMessages :: Game () processMessages :: Game ()
processMessages = do processMessages = do

View file

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