fix communication

This commit is contained in:
nek0 2023-12-11 07:07:09 +01:00
parent c68bb2a369
commit 46f41519fc
3 changed files with 46 additions and 40 deletions

View file

@ -1,14 +1,18 @@
{-# LANGUAGE LambdaCase #-}
module Client.Communication where
import Control.Monad (void)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Network.Socket
import qualified Data.Vector.Storable as VS
import System.IO
import Foreign hiding (void)
import Network.Socket
-- internal imports
@ -21,8 +25,6 @@ connectSocket path = do
sock <- socket AF_UNIX Stream defaultProtocol
setSocketOption sock KeepAlive 1
connect sock (SockAddrUnix path)
-- handle <- socketToHandle sock ReadWriteMode
-- hSetBuffering handle (BlockBuffering Nothing)
pure sock
-- | Sends a specified message through given socket to the server
@ -31,29 +33,24 @@ sendMessage
-> Socket
-> IO ()
sendMessage msg sock = do
handle <- socketToHandle sock WriteMode
hSetBuffering handle (BlockBuffering Nothing)
let msgJson = A.encode msg
B.hPutStr handle $ B.toStrict msgJson
hFlush handle
-- hClose handle
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
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"
let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg
jsonMsg <- maybe
(error $ "unexpected message from Server: " <> show msg)
pure
mJsonMsg
free ptr
pure jsonMsg

View file

@ -14,9 +14,14 @@ import Control.Monad.RWS.Strict
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.UUID.V4
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
import Network.Socket as Net
import System.IO
@ -82,12 +87,7 @@ processRequests = do
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) clientHandle
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
STM.putTMVar socketList ((clientSock, Nothing) : list)
@ -99,12 +99,11 @@ sendMessage
-> Socket
-> IO ()
sendMessage msg sock = do
handle <- socketToHandle sock WriteMode
hSetBuffering handle (BlockBuffering Nothing)
let msgJson = A.encode msg
B.hPutStr handle $ B.toStrict msgJson
hFlush handle
-- hClose handle
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
-- | process incoming messages from clients
processMessages :: Game ()
@ -117,12 +116,20 @@ processMessages = do
)
clients
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> IO ()
receiveMessage clientSocket = do
clientHandle <- socketToHandle clientSocket ReadMode
hSetBuffering clientHandle (BlockBuffering Nothing)
message <- hGetContents clientHandle
putStr message
-- hClose connectionHandle
receiveMessage sock = do
let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength
when (bufferLength > 0) $ do
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessages
jsonMsg <- maybe
(error $ "unexpected message from Server: " <> show msg)
pure
mJsonMsg
free ptr
print jsonMsg

View file

@ -44,6 +44,7 @@ executable wizard-wipeout-client
, network
, optparse-applicative
, uuid
, vector
, vty
, wizard-wipeout
hs-source-dirs: src-client
@ -74,6 +75,7 @@ executable wizard-wipeout-server
, stm
, unix
, uuid
, vector
, wizard-wipeout
, yaml
hs-source-dirs: src-server