wizard-wipeout/src-server/Server/Communication/Receive.hs
2024-05-01 23:52:49 +02:00

55 lines
1.3 KiB
Haskell

module Server.Communication.Receive where
import qualified Control.Concurrent.STM as STM
import Control.Exception
import Control.Monad.IO.Class
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Foreign.Marshal
import Network.Socket
import Library.Types
import Server.Communication.Send
import Server.Types
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> STM.TMVar [ClientComms]
-> IO ()
receiveMessage sock queue clientList = do
let maxBufferLength = 4096
mMsg <- do
ptr <- mallocArray maxBufferLength
eBufferLength <-
try $ recvBuf sock ptr maxBufferLength
bufferLength <- case eBufferLength of
Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…"
dropClient clientList sock
pure 0
Right len -> pure len
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
free ptr
if bufferLength > 0
then
pure mJsonMsg
else
pure Nothing
maybe
(pure ())
(\msg -> do
liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mMsg