From c68bb2a369ab3a5b3ffabf8ffe900db7811e9ca2 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 10 Dec 2023 20:12:53 +0100 Subject: [PATCH] messing around --- configuration.yaml | 2 +- src-client/Client/Communication.hs | 49 +++++++++++++++++++++-- src-client/Client/Types.hs | 6 +-- src-client/Main.hs | 37 ++++++----------- src-lib/Library/Types.hs | 2 +- src-lib/Library/Types/Communication.hs | 28 +++++++++++++ src-server/Server/Communication.hs | 55 ++++++++++++-------------- src-server/Server/Types.hs | 2 + 8 files changed, 118 insertions(+), 63 deletions(-) create mode 100644 src-lib/Library/Types/Communication.hs diff --git a/configuration.yaml b/configuration.yaml index 99180ce..73f2c48 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 20 setMapColumns : 20 setSpawnerProbability : 0.01 -setFPS : 30 +setFPS : 1 diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 4de9710..e7f6ed7 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -1,16 +1,59 @@ +{-# LANGUAGE LambdaCase #-} module Client.Communication where +import qualified Data.Aeson as A + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as B8 + import Network.Socket import System.IO +-- internal imports + +import Library.Types + connectSocket :: FilePath - -> IO Handle + -> IO Socket connectSocket path = do sock <- socket AF_UNIX Stream defaultProtocol setSocketOption sock KeepAlive 1 connect sock (SockAddrUnix path) - handle <- socketToHandle sock ReadWriteMode + -- handle <- socketToHandle sock ReadWriteMode + -- hSetBuffering handle (BlockBuffering Nothing) + pure sock + +-- | Sends a specified message through given socket to the server +sendMessage + :: ClientMessages + -> Socket + -> IO () +sendMessage msg sock = do + handle <- socketToHandle sock WriteMode hSetBuffering handle (BlockBuffering Nothing) - pure handle + let msgJson = A.encode msg + B.hPutStr handle $ B.toStrict msgJson + hFlush handle + -- hClose handle + +receiveMessage + :: Socket + -> IO ServerMessage +receiveMessage sock = do + handle <- socketToHandle sock ReadMode + hSetBuffering handle LineBuffering + handleOpen <- hIsOpen handle + if handleOpen + then do + message <- hGetContents handle + let mJsonMessage = A.decode' $ B8.pack message :: Maybe ServerMessage + errMsg = error $ "unexpected message from Server: " <> message + -- hClose handle + maybe + errMsg + pure + mJsonMessage + else + error "Handle is closed" diff --git a/src-client/Client/Types.hs b/src-client/Client/Types.hs index 0b99fed..10f8696 100644 --- a/src-client/Client/Types.hs +++ b/src-client/Client/Types.hs @@ -4,9 +4,9 @@ import Control.Monad.RWS import Data.UUID -import Options.Applicative as O +import Network.Socket -import System.IO +import Options.Applicative as O -- internal imports @@ -24,7 +24,7 @@ options = Options ) data ReaderContainer = ReaderContainer - { rcSocketHandle :: Handle + { rcSocketHandle :: Socket , rcClientUUID :: UUID } diff --git a/src-client/Main.hs b/src-client/Main.hs index bca4e8b..d3f568a 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -3,14 +3,8 @@ 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 - -- internal imports import Client.Communication @@ -23,27 +17,18 @@ 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 + sock <- connectSocket socketLocation + putStrLn "connected" + sendMessage (IdRequest) sock threadDelay $ 5 * 10 ^ 6 - hPutStrLn handle "Goodbye!" - hFlush handle - threadDelay $ 5 * 10 ^ 6 - -- end mock + -- message <- receiveMessage sock + -- putStrLn $ "getting first message" <> show message + -- let clientUUID = case message of + -- (AcceptClient aclientUUID ) -> aclientUUID + -- x -> error $ "unexpected message from server: " <> show message + -- let reader = ReaderContainer sock clientUUID + -- putStrLn $ "received uuid " <> show clientUUID + -- threadDelay $ 5 * 10 ^ 6 where opts = info (options <**> helper) ( fullDesc diff --git a/src-lib/Library/Types.hs b/src-lib/Library/Types.hs index 497c24e..ec0d605 100644 --- a/src-lib/Library/Types.hs +++ b/src-lib/Library/Types.hs @@ -1,6 +1,6 @@ module Library.Types ( module T - , module Library.Types + , module Library.Types ) where import Data.Matrix diff --git a/src-lib/Library/Types/Communication.hs b/src-lib/Library/Types/Communication.hs new file mode 100644 index 0000000..b4e6a3d --- /dev/null +++ b/src-lib/Library/Types/Communication.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +module Library.Types.Communication where + +import Data.Aeson + +import Data.UUID + +import GHC.Generics + +data ServerMessage + = ServerQuit + | AcceptClient + { acClientUUID :: UUID + } + deriving (Eq, Show, Generic) + +instance FromJSON ServerMessage + +instance ToJSON ServerMessage + +data ClientMessages + = ClientQuit + | IdRequest + deriving (Eq, Show, Generic) + +instance FromJSON ClientMessages + +instance ToJSON ClientMessages diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index d324b7f..dd83d45 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -59,7 +59,7 @@ terminateGameOnSigint = do disconnectClients clients threadDelay (10 ^ 6) (SockAddrUnix path) <- getSocketName sock - close' sock + close sock removeIfExists path -- Raise SIGINT again so it does not get blocked raiseSignal keyboardSignal @@ -69,7 +69,7 @@ terminateGameOnSigint = do disconnectClients = mapM_ (\(clientSocket, mThread) -> do maybe (pure ()) killThread mThread - close' clientSocket + close clientSocket ) -- | Process incoming connection requests @@ -80,11 +80,14 @@ processRequests = do void $ liftIO $ forkIO $ acceptConnection mainSocket socketList where acceptConnection mainSocket socketList = do + putStrLn "accepting new connections…" (clientSock, _) <- accept mainSocket + -- clientHandle <- socketToHandle clientSock ReadWriteMode + -- hSetBuffering clientHandle (BlockBuffering Nothing) putStrLn "accepted new connection" - uuid <- nextRandom - putStrLn $ "accepting client with uuid " <> show uuid - sendMessage (AcceptClient uuid) clientSock + -- uuid <- nextRandom + -- putStrLn $ "accepting client with uuid " <> show uuid + -- sendMessage (AcceptClient uuid) clientHandle liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList STM.putTMVar socketList ((clientSock, Nothing) : list) @@ -96,36 +99,30 @@ sendMessage -> Socket -> IO () sendMessage msg sock = do - connectionHandle <- socketToHandle sock WriteMode - hSetBuffering connectionHandle (BlockBuffering Nothing) + handle <- socketToHandle sock WriteMode + hSetBuffering handle (BlockBuffering Nothing) let msgJson = A.encode msg - B.hPutStr connectionHandle $ B.toStrict msgJson - hFlush connectionHandle - hClose connectionHandle + B.hPutStr handle $ B.toStrict msgJson + hFlush handle + -- hClose handle -- | process incoming messages from clients processMessages :: Game () processMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar - newClients <- foldM - (\acc (clientSocket, mThread) -> - case mThread of - Nothing -> liftIO $ do - thread <- forkIO - (listenTo clientSocket) - pure $ (clientSocket, Just thread) : acc - Just _ -> liftIO $ do - pure acc + mapM_ + (\(clientSocket, _) -> liftIO $ + receiveMessage clientSocket ) - [] clients - liftIO $ STM.atomically $ do - void $ STM.swapTMVar clientsVar newClients - where - listenTo clientSocket = do - connectionHandle <- socketToHandle clientSocket ReadMode - hSetBuffering connectionHandle LineBuffering - message <- hGetContents connectionHandle - putStr message - hClose connectionHandle + +receiveMessage + :: Socket + -> IO () +receiveMessage clientSocket = do + clientHandle <- socketToHandle clientSocket ReadMode + hSetBuffering clientHandle (BlockBuffering Nothing) + message <- hGetContents clientHandle + putStr message + -- hClose connectionHandle diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index aafda78..fef0cf6 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -17,6 +17,8 @@ import Network.Socket import Options.Applicative as O +import System.IO + --internal imports import Library.Types