135 lines
3.2 KiB
Haskell
135 lines
3.2 KiB
Haskell
{-# 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
|