wizard-wipeout/src-client/Client/Communication.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Client.Communication where

import qualified Control.Concurrent.STM as STM

import Control.Monad.RWS

import qualified Data.Aeson as A

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8

import Data.UUID

import qualified Data.Vector.Storable as VS

import Foreign hiding (void)

import Graphics.Vty as Vty

import Network.Socket

import System.Posix.Signals

-- internal imports

import Library.Types
import Client.Types

connectSocket
  :: FilePath
  -> IO Socket
connectSocket path = do
  sock <- socket AF_UNIX Stream defaultProtocol
  setSocketOption sock KeepAlive 1
  connect sock (SockAddrUnix path)
  pure sock

-- | Sends a specified message through given socket to the server
sendMessage
  :: ClientMessage
  -> Socket
  -> IO ()
sendMessage msg sock = do
  let msgJson = A.encode msg
      msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
  VS.unsafeWith
    msgVector
    (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))

handleMessages
  :: Game ()
handleMessages = do
  queue <- asks rcQueue
  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
  mapM_
    handleMessage
    msgs

handleMessage
  :: ServerMessage
  -> Game ()
handleMessage ServerQuit = do
  st <- get
  let stateCont = scClientState st
  liftIO $ STM.atomically $ do
    stateContainer <- STM.readTMVar stateCont
    void $ STM.swapTMVar stateCont $ stateContainer
      { clientStop = True
      }
  put $ st
    { scClientState = stateCont
    }
  liftIO $ putStrLn "Quitting due to server shutdown"

handleMessage (TickUpdate slice wizard) = do
  modify' (\st@(StateContainer {}) ->
    st
      { scWizard   = wizard
      , scMapSlice = slice
      }
    )

handleMessage x =
  liftIO $ putStrLn $ "received unexpected message from server: " <> show x

receiveMessage
  :: Socket
  -> STM.TQueue ServerMessage
  -> IO ()
receiveMessage sock queue = do
  let maxBufferLength = 4096
  ptr <- mallocArray maxBufferLength
  bufferLength <- recvBuf sock ptr maxBufferLength
  rawMsg <- B.pack <$> peekArray bufferLength ptr
  let msgs = map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg
  mapM_
    (\msg -> do
      let mJsonMsg = A.decode' msg
      maybe
        (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg))
        (STM.atomically . STM.writeTQueue queue)
        mJsonMsg
    )
    msgs

-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
  :: Game ()
terminateGameOnSigint = do
  -- sock <- asks rcSocket
  -- clientId <- asks rcClientUUID
  clientState <- gets scClientState
  void $ liftIO $ installHandler
    keyboardSignal
    (CatchOnce $ do
      currentState <- STM.atomically $ do
        currentState <- STM.readTMVar clientState
        void $ STM.swapTMVar clientState $ currentState { clientStop = True }
        pure currentState
      Vty.shutdown (clientVty currentState)
      -- partingMessage clientId sock
      -- Raise SIGINT again so it does not get blocked
      -- raiseSignal keyboardSignal
    )
    Nothing

partingMessage
  :: UUID
  -> Socket
  -> IO ()
partingMessage clientId sock = do
  sendMessage (ClientMessage clientId ClientQuit) sock
  -- close sock