{-# 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 logPrintIO curLevel Verbose $ show 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