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
setMapColumns : 20
setSpawnerProbability : 0.01
setFPS : 30
setFPS : 1

View file

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

View file

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

View file

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

View file

@ -1,6 +1,6 @@
module Library.Types
( module T
, module Library.Types
, module Library.Types
) where
import Data.Matrix

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

View file

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