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

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

import Control.Exception

import qualified Control.Concurrent.STM as STM

import Control.Monad

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.IORef

import Data.UUID

import Foreign hiding (void)

import Network.Socket

import System.Posix.Signals

-- internal imports

import Library.Types
import Client.Types
import GHC.Conc (threadDelay)

connectSocket
  :: FilePath
  -> IO Socket
connectSocket path = do
  sock <- socket AF_UNIX Stream 0
  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
  putStrLn $ "sending message: " <> show msg
  let msgJson = A.encode msg
      msgList = B.unpack $ B.toStrict msgJson
  putStrLn $ "sending raw message buffer: " <> show msgList
  ptr <- newArray msgList
  void $ sendBuf sock ptr (length msgList)
  putStrLn "raw message buffer sent"
  free ptr

handleMessages
  :: Game ()
handleMessages = do
  queue <- asks rcMessageQueue
  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
  mapM_
    handleMessage
    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
  liftIO $ sendMessage
    ( ClientMessage
      cid
      (Pong id')
    )
    sock

handleMessage (TickUpdate !slice !wizard) = do
  st <- get
  let !newState = st
        { scWizard   = wizard
        , scMapSlice = slice
        }
  put newState

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
  writeIORef (scStopper st) 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
  -- putStrLn $ "received buffer of length: " <> show ebufferLength
  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
  -- putStrLn $ "received raw message: " <> show rawMsg
  let msgs =
        if B.length rawMsg < 1
        then []
        else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg
  -- putStrLn $ "resulting split messages: " <> show msgs
  mapM_
    (\msg -> do
      let mJsonMsg = A.decode' msg
      maybe
        (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg))
        (\jsonMsg -> do
          STM.atomically $ STM.writeTQueue queue jsonMsg
        )
        mJsonMsg
    )
    msgs
  free ptr

-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
  :: IORef Bool
  -> Game ()
terminateGameOnSigint stopper = do
  rc <- ask
  void $ liftIO $ installHandler
    keyboardSignal
    (CatchOnce $ do
      putStrLn "receiveMessage: SIGINT caught, terminating…"
      liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc)
      atomicWriteIORef stopper True
      -- Vty.shutdown (clientVty currentState)
      -- 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
  putStrLn "sent parting message to server"
  threadDelay (10 ^ 6)