client: found and fixed mem leak

This commit is contained in:
nek0 2024-04-07 13:35:48 +02:00
parent 3349d21195
commit ff3fd6415f
5 changed files with 25 additions and 17 deletions

View file

@ -1,11 +1,14 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Client.Communication where module Client.Communication where
import Control.Exception import Control.Exception
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.RWS import Control.Monad.RWS
import qualified Data.Aeson as A import qualified Data.Aeson as A
@ -51,10 +54,11 @@ sendMessage st msg sock = do
VS.unsafeWith VS.unsafeWith
msgVector msgVector
(\ptr -> do (\ptr -> do
eResult <- try $ sendBuf sock ptr (VS.length msgVector) void $ sendBuf sock ptr (VS.length msgVector)
case eResult of -- eResult <- try $ sendBuf sock ptr (VS.length msgVector)
Left (_ :: IOException) -> gracefulExit st "sendMessage: Quitting due to connection loss…" -- case eResult of
Right _ -> pure () -- Left (_ :: IOException) -> gracefulExit st "sendMessage: Quitting due to connection loss…"
-- Right _ -> pure ()
) )
handleMessages handleMessages
@ -88,13 +92,13 @@ handleMessage (Ping id') = do
) )
sock sock
handleMessage (TickUpdate slice wizard) = do -- handleMessage (TickUpdate !slice !wizard) = do
modify' (\st@(StateContainer {}) -> -- st <- get
st -- let !newState = st
{ scWizard = wizard -- { scWizard = wizard
, scMapSlice = slice -- , scMapSlice = slice
} -- }
) -- put newState
handleMessage x = handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x liftIO $ putStrLn $ "received unexpected message from server: " <> show x
@ -160,7 +164,7 @@ terminateGameOnSigint = do
-- Vty.shutdown (clientVty currentState) -- Vty.shutdown (clientVty currentState)
partingMessage st clientId sock partingMessage st clientId sock
-- Raise SIGINT again so it does not get blocked -- Raise SIGINT again so it does not get blocked
raiseSignal keyboardSignal -- raiseSignal keyboardSignal
) )
Nothing Nothing

View file

@ -32,9 +32,10 @@ runGame = do
(not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState)) (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
(do (do
handleMessages handleMessages
pure ()
-- draw -- draw
) )
-- liftIO $ killThread recvThread liftIO $ killThread recvThread
handleEvent handleEvent
:: Maybe Event :: Maybe Event

View file

@ -82,6 +82,7 @@ main = do
partingMessage initState clientId sock partingMessage initState clientId sock
threadDelay 100 threadDelay 100
close sock close sock
putStrLn "bye bye"
where where
opts = info (options <**> helper) opts = info (options <**> helper)
( fullDesc ( fullDesc

View file

@ -5,6 +5,8 @@ import Control.Concurrent
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.RWS.Strict import Control.Monad.RWS.Strict
import Control.Monad.Loops import Control.Monad.Loops

View file

@ -14,7 +14,7 @@ extra-doc-files: CHANGELOG.md
-- extra-source-files: -- extra-source-files:
common warnings common warnings
ghc-options: -Wall -threaded -prof ghc-options: -Wall -threaded -rtsopts
library library
import: warnings import: warnings
@ -22,7 +22,7 @@ library
Library.Types.Communication Library.Types.Communication
Library.Types.Map Library.Types.Map
Library.Types.Player Library.Types.Player
build-depends: base ^>=4.17.2.1 build-depends: base >=4.17.2.1
, aeson , aeson
, linear , linear
, matrix , matrix
@ -40,7 +40,7 @@ executable wizard-wipeout-client
Client.Graphics Client.Graphics
Client.Types Client.Types
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.17.2.1 build-depends: base >=4.17.2.1
, aeson , aeson
, bytestring , bytestring
, linear , linear
@ -67,7 +67,7 @@ executable wizard-wipeout-server
Server.Types Server.Types
Server.Util Server.Util
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.17.2.1 build-depends: base >=4.17.2.1
, aeson , aeson
, bytestring , bytestring
, directory , directory