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

174 lines
4.1 KiB
Haskell

{-# 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