fix communication

src-client/Client/Communication.hs

@@ -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
+      msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
-  hFlush handle
+  VS.unsafeWith
-  -- hClose handle
+    msgVector
+    (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
 
 receiveMessage
   :: Socket
   -> IO ServerMessage
 receiveMessage sock = do
-  handle <- socketToHandle sock ReadMode
+  let maxBufferLength = 4096
-  hSetBuffering handle LineBuffering
+  ptr <- mallocArray maxBufferLength
-  handleOpen <- hIsOpen handle
+  bufferLength <- recvBuf sock ptr maxBufferLength
-  if handleOpen
+  msg <- B.pack <$> peekArray bufferLength ptr
-  then do
+  let mJsonMsg = A.decode' $ B8.fromStrict msg
-    message <- hGetContents handle
+  jsonMsg <- maybe
-    let mJsonMessage = A.decode' $ B8.pack message :: Maybe ServerMessage
+    (error $ "unexpected message from Server: " <> show msg)
-        errMsg = error $ "unexpected message from Server: " <> message
-    -- hClose handle
-    maybe
-      errMsg
     pure
-      mJsonMessage
+    mJsonMsg
-  else
+  free ptr
-    error "Handle is closed"
+  pure jsonMsg

src-server/Server/Communication.hs

@@ -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
+      msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
-  hFlush handle
+  VS.unsafeWith
-  -- hClose handle
+    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
+receiveMessage sock = do
-  clientHandle <- socketToHandle clientSocket ReadMode
+  let maxBufferLength = 4096
-  hSetBuffering clientHandle (BlockBuffering Nothing)
+  ptr <- mallocArray maxBufferLength
-  message <- hGetContents clientHandle
+  bufferLength <- recvBuf sock ptr maxBufferLength
-  putStr message
+  when (bufferLength > 0) $ do
-  -- hClose connectionHandle
+    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

wizard-wipeout.cabal

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