From aa1805ce19cb718dbb134a22ce467e1029a3ca09 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 10 Dec 2023 17:00:50 +0100 Subject: [PATCH] first actual message passing --- src-client/Main.hs | 20 ++++++++++++++++++++ src-lib/Library/Types.hs | 7 ++++++- src-server/Server/Communication.hs | 24 ++++++++++++++++++++++++ wizard-wipeout.cabal | 4 ++++ 4 files changed, 54 insertions(+), 1 deletion(-) diff --git a/src-client/Main.hs b/src-client/Main.hs index 38d32e1..bca4e8b 100644 --- a/src-client/Main.hs +++ b/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) diff --git a/src-lib/Library/Types.hs b/src-lib/Library/Types.hs index 57589ce..497c24e 100644 --- a/src-lib/Library/Types.hs +++ b/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 diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index cf459d5..d324b7f 100644 --- a/src-server/Server/Communication.hs +++ b/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 diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index 8016df4..a9872e8 100644 --- a/wizard-wipeout.cabal +++ b/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