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

159 lines
3.6 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 #-}
2024-04-07 11:35:48 +00:00
{-# LANGUAGE BangPatterns #-}
module Client.Communication where
2024-03-29 22:01:41 +00:00
import Control.Exception
import qualified Control.Concurrent.STM as STM
2024-04-07 11:35:48 +00:00
import Control.Monad
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
2024-04-17 17:44:47 +00:00
import Data.IORef
2023-12-20 08:04:50 +00:00
import Data.UUID
2023-12-11 06:07:09 +00:00
import Foreign hiding (void)
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
2024-04-19 18:18:49 +00:00
:: ClientMessage
2023-12-10 19:12:53 +00:00
-> Socket
-> IO ()
2024-04-19 18:18:49 +00:00
sendMessage msg sock = do
2023-12-10 19:12:53 +00:00
let msgJson = A.encode msg
2024-04-17 17:44:47 +00:00
msgList = B.unpack $ B.toStrict msgJson
ptr <- newArray msgList
void $ sendBuf sock ptr (length msgList)
free ptr
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_
2024-03-29 22:01:41 +00:00
(\msg -> do
2024-05-01 20:42:49 +00:00
-- liftIO $ putStrLn $ "Handling following: " <> show msg
2024-03-29 22:01:41 +00:00
handleMessage msg
)
2023-12-20 07:12:22 +00:00
msgs
handleMessage
:: ServerMessage
-> Game ()
handleMessage ServerQuit = do
2023-12-20 08:04:50 +00:00
st <- get
2024-03-29 22:01:41 +00:00
liftIO (gracefulExit st "Quitting due to server shutdown")
2023-12-20 07:12:22 +00:00
2024-02-02 14:48:55 +00:00
handleMessage (Ping id') = do
cid <- asks rcClientUUID
sock <- asks rcSocket
liftIO $ sendMessage
( ClientMessage
cid
(Pong id')
)
sock
2024-04-07 11:35:48 +00:00
-- handleMessage (TickUpdate !slice !wizard) = do
-- st <- get
-- let !newState = st
-- { scWizard = wizard
-- , scMapSlice = slice
-- }
-- put newState
2023-12-20 07:12:22 +00:00
handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x
2024-03-29 22:01:41 +00:00
-- Gracefully shut down the client with an error message
gracefulExit
:: StateContainer
-> String
-> IO ()
gracefulExit st reason = do
liftIO $ putStrLn reason
2024-04-19 18:18:49 +00:00
writeIORef (scStopper st) True
2024-03-29 22:01:41 +00:00
2023-12-10 19:12:53 +00:00
receiveMessage
:: Socket
-> STM.TQueue ServerMessage
2024-03-29 22:01:41 +00:00
-> StateContainer
-> IO ()
2024-03-29 22:01:41 +00:00
receiveMessage sock queue st = do
2023-12-11 06:07:09 +00:00
let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength
2024-03-29 22:01:41 +00:00
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
2023-12-23 10:38:57 +00:00
rawMsg <- B.pack <$> peekArray bufferLength ptr
2024-02-02 14:48:55 +00:00
let msgs =
if B.length rawMsg < 1
then []
else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg
2023-12-23 10:38:57 +00:00
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
2024-04-17 17:44:47 +00:00
free ptr
2023-12-12 08:47:50 +00:00
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
2024-04-17 17:44:47 +00:00
:: IORef Bool
-> Game ()
terminateGameOnSigint stopper = do
2024-04-19 18:18:49 +00:00
rc <- ask
2023-12-12 08:47:50 +00:00
void $ liftIO $ installHandler
keyboardSignal
(CatchOnce $ do
2024-04-05 14:24:46 +00:00
putStrLn "receiveMessage: SIGINT caught, terminating…"
2024-04-19 18:18:49 +00:00
liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc)
2024-04-17 17:44:47 +00:00
atomicWriteIORef stopper True
2024-03-29 03:14:21 +00:00
-- Vty.shutdown (clientVty currentState)
2023-12-12 08:47:50 +00:00
-- Raise SIGINT again so it does not get blocked
2024-04-07 11:35:48 +00:00
-- raiseSignal keyboardSignal
2023-12-12 08:47:50 +00:00
)
Nothing
2023-12-20 08:04:50 +00:00
partingMessage
2024-04-19 18:18:49 +00:00
:: UUID
2023-12-20 08:04:50 +00:00
-> Socket
-> IO ()
2024-04-19 18:18:49 +00:00
partingMessage clientId sock = do
putStrLn "sending parting message to server…"
sendMessage (ClientMessage clientId ClientQuit) sock