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

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

import Control.Exception

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
  :: StateContainer
  -> ClientMessage
  -> Socket
  -> IO ()
sendMessage st msg sock = do
  let msgJson = A.encode msg
      msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
  VS.unsafeWith
    msgVector
    (\ptr -> do
      eResult <- try $ sendBuf sock ptr (VS.length msgVector)
      case eResult of
        Left (_ :: IOException) -> gracefulExit st "sendMessage:  Quitting due to connection loss…"
        Right _ -> pure ()
      )

handleMessages
  :: Game ()
handleMessages = do
  queue <- asks rcQueue
  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
  mapM_
    (\msg -> do
      -- liftIO $ putStrLn $ "Handling following: " <> show msg
      handleMessage msg
    )
    msgs

handleMessage
  :: ServerMessage
  -> Game ()
handleMessage ServerQuit = do
  st <- get
  liftIO (gracefulExit st "Quitting due to server shutdown")

handleMessage (Ping id') = do
  cid <- asks rcClientUUID
  sock <- asks rcSocket
  st <- get
  liftIO $ sendMessage
    st
    ( ClientMessage
      cid
      (Pong id')
    )
    sock

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

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

-- Gracefully shut down the client with an error message
gracefulExit
  :: StateContainer
  -> String
  -> IO ()
gracefulExit st reason = do
  liftIO $ putStrLn reason
  let stateCont = scClientState st
  liftIO $ STM.atomically $ do
    stateContainer <- STM.readTMVar stateCont
    void $ STM.swapTMVar stateCont $ stateContainer
      { clientStop = True
      }

receiveMessage
  :: Socket
  -> STM.TQueue ServerMessage
  -> StateContainer
  -> IO ()
receiveMessage sock queue st = do
  let maxBufferLength = 4096
  ptr <- mallocArray maxBufferLength
  ebufferLength <- try $ recvBuf sock ptr maxBufferLength
  bufferLength <- case ebufferLength of
    Left (_ :: IOException) ->  do
      gracefulExit st "Quitting due to connection loss"
      pure 0
    Right len -> pure len
  rawMsg <- B.pack <$> peekArray bufferLength ptr
  let msgs =
        if B.length rawMsg < 1
        then []
        else 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
  st <- get
  void $ liftIO $ installHandler
    keyboardSignal
    (CatchOnce $ do
      putStrLn "receiveMessage: SIGINT caught, terminating…"
      STM.atomically $ do
        currentState <- STM.readTMVar clientState
        void $ STM.swapTMVar clientState $ currentState { clientStop = True }
      -- Vty.shutdown (clientVty currentState)
      partingMessage st clientId sock
      -- Raise SIGINT again so it does not get blocked
      raiseSignal keyboardSignal
    )
    Nothing

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