messing around

This commit is contained in:
nek0 2023-12-10 20:12:53 +01:00
parent aa1805ce19
commit c68bb2a369
8 changed files with 118 additions and 63 deletions

View file

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

View file

@ -1,16 +1,59 @@
{-# LANGUAGE LambdaCase #-}
module Client.Communication where 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 Network.Socket
import System.IO import System.IO
-- internal imports
import Library.Types
connectSocket connectSocket
:: FilePath :: FilePath
-> IO Handle -> IO Socket
connectSocket path = do connectSocket path = do
sock <- socket AF_UNIX Stream defaultProtocol sock <- socket AF_UNIX Stream defaultProtocol
setSocketOption sock KeepAlive 1 setSocketOption sock KeepAlive 1
connect sock (SockAddrUnix path) 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) 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"

View file

@ -4,9 +4,9 @@ import Control.Monad.RWS
import Data.UUID import Data.UUID
import Options.Applicative as O import Network.Socket
import System.IO import Options.Applicative as O
-- internal imports -- internal imports
@ -24,7 +24,7 @@ options = Options
) )
data ReaderContainer = ReaderContainer data ReaderContainer = ReaderContainer
{ rcSocketHandle :: Handle { rcSocketHandle :: Socket
, rcClientUUID :: UUID , rcClientUUID :: UUID
} }

View file

@ -3,14 +3,8 @@ 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
-- internal imports -- internal imports
import Client.Communication import Client.Communication
@ -23,27 +17,18 @@ 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 sock <- connectSocket socketLocation
message <- hGetContents handle putStrLn "connected"
let mJsonMessage = decode' $ B8.pack message :: Maybe ServerMessage sendMessage (IdRequest) sock
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 threadDelay $ 5 * 10 ^ 6
hPutStrLn handle "Goodbye!" -- message <- receiveMessage sock
hFlush handle -- putStrLn $ "getting first message" <> show message
threadDelay $ 5 * 10 ^ 6 -- let clientUUID = case message of
-- end mock -- (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 where
opts = info (options <**> helper) opts = info (options <**> helper)
( fullDesc ( fullDesc

View file

@ -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

View file

@ -59,7 +59,7 @@ terminateGameOnSigint = do
disconnectClients clients disconnectClients clients
threadDelay (10 ^ 6) threadDelay (10 ^ 6)
(SockAddrUnix path) <- getSocketName sock (SockAddrUnix path) <- getSocketName sock
close' sock close sock
removeIfExists path removeIfExists path
-- Raise SIGINT again so it does not get blocked -- Raise SIGINT again so it does not get blocked
raiseSignal keyboardSignal raiseSignal keyboardSignal
@ -69,7 +69,7 @@ terminateGameOnSigint = do
disconnectClients = mapM_ disconnectClients = mapM_
(\(clientSocket, mThread) -> do (\(clientSocket, mThread) -> do
maybe (pure ()) killThread mThread maybe (pure ()) killThread mThread
close' clientSocket close clientSocket
) )
-- | Process incoming connection requests -- | Process incoming connection requests
@ -80,11 +80,14 @@ processRequests = do
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
where where
acceptConnection mainSocket socketList = do acceptConnection mainSocket socketList = do
putStrLn "accepting new connections…"
(clientSock, _) <- accept mainSocket (clientSock, _) <- accept mainSocket
-- clientHandle <- socketToHandle clientSock ReadWriteMode
-- hSetBuffering clientHandle (BlockBuffering Nothing)
putStrLn "accepted new connection" putStrLn "accepted new connection"
uuid <- nextRandom -- uuid <- nextRandom
putStrLn $ "accepting client with uuid " <> show uuid -- putStrLn $ "accepting client with uuid " <> show uuid
sendMessage (AcceptClient uuid) clientSock -- sendMessage (AcceptClient uuid) clientHandle
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)
@ -96,36 +99,30 @@ sendMessage
-> Socket -> Socket
-> IO () -> IO ()
sendMessage msg sock = do sendMessage msg sock = do
connectionHandle <- socketToHandle sock WriteMode handle <- socketToHandle sock WriteMode
hSetBuffering connectionHandle (BlockBuffering Nothing) hSetBuffering handle (BlockBuffering Nothing)
let msgJson = A.encode msg let msgJson = A.encode msg
B.hPutStr connectionHandle $ B.toStrict msgJson B.hPutStr handle $ B.toStrict msgJson
hFlush connectionHandle hFlush handle
hClose connectionHandle -- hClose handle
-- | process incoming messages from clients -- | process incoming messages from clients
processMessages :: Game () processMessages :: Game ()
processMessages = do processMessages = do
clientsVar <- gets scClientSockets clientsVar <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
newClients <- foldM mapM_
(\acc (clientSocket, mThread) -> (\(clientSocket, _) -> liftIO $
case mThread of receiveMessage clientSocket
Nothing -> liftIO $ do
thread <- forkIO
(listenTo clientSocket)
pure $ (clientSocket, Just thread) : acc
Just _ -> liftIO $ do
pure acc
) )
[]
clients clients
liftIO $ STM.atomically $ do
void $ STM.swapTMVar clientsVar newClients receiveMessage
where :: Socket
listenTo clientSocket = do -> IO ()
connectionHandle <- socketToHandle clientSocket ReadMode receiveMessage clientSocket = do
hSetBuffering connectionHandle LineBuffering clientHandle <- socketToHandle clientSocket ReadMode
message <- hGetContents connectionHandle hSetBuffering clientHandle (BlockBuffering Nothing)
message <- hGetContents clientHandle
putStr message putStr message
hClose connectionHandle -- hClose connectionHandle

View file

@ -17,6 +17,8 @@ import Network.Socket
import Options.Applicative as O import Options.Applicative as O
import System.IO
--internal imports --internal imports
import Library.Types import Library.Types