158 lines
3.6 KiB
Haskell
158 lines
3.6 KiB
Haskell
{-# 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
|
|
|
|
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
|
|
msgList = B.unpack $ B.toStrict msgJson
|
|
ptr <- newArray msgList
|
|
void $ sendBuf sock ptr (length msgList)
|
|
free ptr
|
|
|
|
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
|
|
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
|
|
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
|
|
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
|
|
putStrLn "sending parting message to server…"
|
|
sendMessage (ClientMessage clientId ClientQuit) sock
|