{-# 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.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 void $ sendBuf sock ptr (VS.length msgVector) ) 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 -- 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 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