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

{-# 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]
  -> Socket
  -> STM.TQueue ClientMessage
  -> IO ()
receiveMessage curLevel socketList queueList sock queue = do
  randSleep <- randomRIO (1, 1000)
  threadDelay randSleep
  let maxBufferLength = 4096
  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