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

136 lines
3.2 KiB
Haskell
Raw Normal View History

2023-12-10 19:12:53 +00:00
{-# LANGUAGE LambdaCase #-}
2023-12-20 07:12:22 +00:00
{-# LANGUAGE RecordWildCards #-}
module Client.Communication where
import qualified Control.Concurrent.STM as STM
2023-12-12 08:47:50 +00:00
import Control.Monad.RWS
2023-12-10 19:12:53 +00:00
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
2023-12-20 08:04:50 +00:00
import Data.UUID
2023-12-11 06:07:09 +00:00
import qualified Data.Vector.Storable as VS
2023-12-11 06:07:09 +00:00
import Foreign hiding (void)
2023-12-13 12:36:06 +00:00
import Graphics.Vty as Vty
2023-12-11 06:07:09 +00:00
import Network.Socket
2023-12-12 08:47:50 +00:00
import System.Posix.Signals
2023-12-10 19:12:53 +00:00
-- internal imports
import Library.Types
2023-12-12 08:47:50 +00:00
import Client.Types
2023-12-10 19:12:53 +00:00
connectSocket
:: FilePath
2023-12-10 19:12:53 +00:00
-> IO Socket
connectSocket path = do
sock <- socket AF_UNIX Stream defaultProtocol
setSocketOption sock KeepAlive 1
connect sock (SockAddrUnix path)
2023-12-10 19:12:53 +00:00
pure sock
-- | Sends a specified message through given socket to the server
sendMessage
2023-12-11 08:49:24 +00:00
:: ClientMessage
2023-12-10 19:12:53 +00:00
-> Socket
-> IO ()
sendMessage msg sock = do
let msgJson = A.encode msg
2023-12-11 06:07:09 +00:00
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
2023-12-10 19:12:53 +00:00
2023-12-20 07:12:22 +00:00
handleMessages
:: Game ()
handleMessages = do
queue <- asks rcQueue
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
handleMessage
msgs
handleMessage
:: ServerMessage
-> Game ()
handleMessage ServerQuit = do
2023-12-20 08:04:50 +00:00
st <- get
let stateCont = scClientState st
2023-12-20 07:12:22 +00:00
liftIO $ STM.atomically $ do
2023-12-20 08:04:50 +00:00
stateContainer <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ stateContainer
2023-12-20 07:12:22 +00:00
{ clientStop = True
}
2023-12-20 08:04:50 +00:00
put $ st
2023-12-20 07:12:22 +00:00
{ scClientState = stateCont
}
liftIO $ putStrLn "Quitting due to server shutdown"
handleMessage (TickUpdate slice wizard) = do
2023-12-20 08:04:50 +00:00
modify' (\st@(StateContainer {}) ->
st
2023-12-20 07:12:22 +00:00
{ scWizard = wizard
, scMapSlice = slice
}
)
handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x
2023-12-10 19:12:53 +00:00
receiveMessage
:: Socket
-> STM.TQueue ServerMessage
-> IO ()
receiveMessage sock queue = do
2023-12-11 06:07:09 +00:00
let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength
2023-12-23 10:38:57 +00:00
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
2024-01-23 10:13:52 +00:00
(putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg))
2023-12-23 10:38:57 +00:00
(STM.atomically . STM.writeTQueue queue)
mJsonMsg
)
msgs
2023-12-12 08:47:50 +00:00
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
:: Game ()
terminateGameOnSigint = do
2023-12-20 08:04:50 +00:00
-- sock <- asks rcSocket
-- clientId <- asks rcClientUUID
2023-12-12 08:47:50 +00:00
clientState <- gets scClientState
void $ liftIO $ installHandler
keyboardSignal
(CatchOnce $ do
2023-12-13 12:36:06 +00:00
currentState <- STM.atomically $ do
2023-12-12 10:52:25 +00:00
currentState <- STM.readTMVar clientState
void $ STM.swapTMVar clientState $ currentState { clientStop = True }
2023-12-13 12:36:06 +00:00
pure currentState
Vty.shutdown (clientVty currentState)
2023-12-20 08:04:50 +00:00
-- partingMessage clientId sock
2023-12-12 08:47:50 +00:00
-- Raise SIGINT again so it does not get blocked
2023-12-13 14:09:27 +00:00
-- raiseSignal keyboardSignal
2023-12-12 08:47:50 +00:00
)
Nothing
2023-12-20 08:04:50 +00:00
partingMessage
:: UUID
-> Socket
-> IO ()
partingMessage clientId sock = do
sendMessage (ClientMessage clientId ClientQuit) sock
-- close sock