wizard-wipeout/src-server/Server/Communication/Receive.hs

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 hiding (void)

import Network.Socket

-- internal imports

import Library.Types

import Server.Communication.Send
import Server.Types

-- | receive a 'ClientMessage'
receiveMessage
  :: STM.TMVar Socket
  -> STM.TQueue ClientMessage
  -> STM.TMVar [ClientComms]
  -> IO ()
receiveMessage sockContainer queue clientList = do
  sock <- STM.atomically $ STM.readTMVar sockContainer
  let maxBufferLength = 4096
  mMsg <- do
    ptr <- mallocArray maxBufferLength
    eBufferLength <-
      try $ recvBuf sock ptr maxBufferLength
    bufferLength <- case eBufferLength of
      Left (e :: IOException) -> do
        putStrLn ("Socket vanished, cleaning up after " <> show e)
        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