76 lines
2.2 KiB
Haskell
76 lines
2.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Server.Communication.Receive where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
|
|
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 hiding (void)
|
|
|
|
import Network.Socket
|
|
|
|
import System.Random
|
|
|
|
-- internal imports
|
|
|
|
import Library.Types
|
|
|
|
import Server.Communication.Send
|
|
import Server.Log (logPrintIO)
|
|
import Server.Types
|
|
|
|
-- | receive a 'ClientMessage'
|
|
receiveMessage
|
|
:: LogLevel
|
|
-> STM.TMVar [ClientSocket]
|
|
-> STM.TMVar [ClientQueue]
|
|
-> STM.TMVar Socket
|
|
-> STM.TQueue ClientMessage
|
|
-> IO ()
|
|
receiveMessage curLevel socketList queueList sockContainer queue = do
|
|
randSleep <- randomRIO (1, 1000)
|
|
threadDelay randSleep
|
|
let maxBufferLength = 4096
|
|
sock <- STM.atomically $ STM.readTMVar sockContainer
|
|
logPrintIO curLevel Verbose "read socket container for receiving"
|
|
ptr <- mallocArray maxBufferLength
|
|
logPrintIO curLevel Verbose "receiving data"
|
|
eBufferLength <-
|
|
try $ recvBuf sock ptr maxBufferLength
|
|
logPrintIO curLevel Verbose $ "received raw buffer length of: " <> show eBufferLength
|
|
bufferLength <- case eBufferLength of
|
|
Left (e :: IOException) -> do
|
|
logPrintIO curLevel Warning ("Socket vanished, cleaning up after " <> show e)
|
|
dropClient curLevel socketList queueList sock
|
|
pure 0
|
|
Right len -> pure len
|
|
logPrintIO curLevel Verbose $ "received buffer of length: " <> show bufferLength
|
|
rawMsg <- B.pack <$> peekArray bufferLength ptr
|
|
free ptr
|
|
logPrintIO curLevel Verbose $ "received data: " <> show rawMsg
|
|
let msgs =
|
|
if B.length rawMsg < 1
|
|
then [] :: [B8.ByteString]
|
|
else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg
|
|
logPrintIO curLevel Verbose $ "received messages: " <> show msgs
|
|
print msgs
|
|
mapM_
|
|
(\msg -> do
|
|
let mJsonMsg = A.decode' msg
|
|
maybe
|
|
(logPrintIO curLevel Warning $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg))
|
|
(\jsonMsg -> do
|
|
STM.atomically $ STM.writeTQueue queue jsonMsg
|
|
)
|
|
mJsonMsg
|
|
)
|
|
msgs
|