mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-12 14:00:14 +00:00
sh
c9ebf72e80
* tests: add SMP proxy relay reconnection tests Reproduces the proxy failing to reconnect to a destination relay when the sender disconnects mid-connection (empty session var left in smpClients). * fix: bracket session var creation to drop it on interrupt getSessVar inserts an empty session var that the connect path then fills with putTMVar. If the connecting thread is killed by an async exception before that fill (a proxy worker on client disconnect, an agent worker on cancel), the empty var was left in the map forever and every later request for that server blocked on it until timing out (permanent PCEResponseTimeout). Wrap get-or-create with withGetSessVar (bracketOnError) at the call sites, so the cleanup is established where the var is created and covers the whole connect: on interrupt before fill the still-empty var is dropped and the next request reconnects. This closes the window between getSessVar and the fill that a handler installed inside the connect function cannot cover. * test: cover session var leak on interrupted connect UtilTests: tryAllErrors rethrows ThreadKilled/StackOverflow (the mechanism that skips putTMVar). SMPProxyTests: agent client reconnection after a cancelled connect, plus a control proving the stalling relay alone does not cause the failure; refine the relay reconnection tests. * refactor --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
138 lines
8.9 KiB
Haskell
138 lines
8.9 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module CoreTests.UtilTests where
|
|
|
|
import AgentTests.FunctionalAPITests ()
|
|
import Control.Exception (AllocationLimitExceeded (..), AsyncException (..), Exception, SomeException, throwIO)
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Class
|
|
import Data.IORef
|
|
import Simplex.Messaging.Util
|
|
import Test.Hspec hiding (fit, it)
|
|
import qualified UnliftIO.Exception as UE
|
|
import Util
|
|
|
|
utilTests :: Spec
|
|
utilTests = do
|
|
describe "problems of lifted try, catch and finally (don't use them)" $ do
|
|
describe "lifted try" $ do
|
|
it "does not catch errors" $ do
|
|
runExceptT (UE.try throwTestError >>= either handleCatch pure) `shouldReturn` Left (TestError "error")
|
|
runExceptT (UE.try throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
|
|
it "with SomeException catches all errors but wraps ExceptT errors" $ do
|
|
runExceptT (UE.try throwTestError >>= either handleException pure) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
|
|
runExceptT (UE.try throwTestException >>= either handleException pure) `shouldReturn` Right "caught user error (error)"
|
|
describe "lifted catch" $ do
|
|
it "does not catch" $ do
|
|
runExceptT (throwTestError `UE.catch` handleCatch) `shouldReturn` Left (TestError "error")
|
|
runExceptT (throwTestException `UE.catch` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
|
|
it "with SomeException catches all errors but wraps ExceptT errors" $ do
|
|
runExceptT (throwTestError `UE.catch` handleException) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
|
|
runExceptT (throwTestException `UE.catch` handleException) `shouldReturn` Right "caught user error (error)"
|
|
describe "lifted finally" $ do
|
|
it "with ExceptT error executes final action and stays in ExceptT monad" $ withFinal $ \final ->
|
|
runExceptT (throwTestError `UE.finally` final) `shouldReturn` Left (TestError "error")
|
|
it "with exception executes final action (not always - race condition?) and throws exception" $ withFinal $ \final ->
|
|
runExceptT (throwTestException `UE.finally` final) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
|
|
describe "problems of tryError and catchError (don't use them)" $ do
|
|
describe "tryError" $ do
|
|
it "catches ExceptT errors but not Exceptions" $ do
|
|
runExceptT (tryError throwTestError >>= either handleCatch pure) `shouldReturn` Right "caught TestError \"error\""
|
|
runExceptT (tryError throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
|
|
describe "catchError" $ do
|
|
it "catches ExceptT errors but not Exceptions" $ do
|
|
runExceptT (throwTestError `catchError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
|
|
runExceptT (throwTestException `catchError` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
|
|
describe "tryAllErrors" $ do
|
|
it "should return ExceptT error as Left" $
|
|
runExceptT (tryAllErrors throwTestError) `shouldReturn` Right (Left (TestError "error"))
|
|
it "should return SomeException as Left" $
|
|
runExceptT (tryAllErrors throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
|
|
it "should return no errors as Right" $
|
|
runExceptT (tryAllErrors noErrors) `shouldReturn` Right (Right "no errors")
|
|
-- tryAllErrors rethrows asynchronous exceptions (it uses UnliftIO.catch). Any recovery placed
|
|
-- after `tryAllErrors action` - e.g. putTMVar to fill a SessionVar - is therefore SKIPPED when
|
|
-- the thread is killed mid-action. Unlike tryAllOwnErrors, it also rethrows the overflow exceptions.
|
|
it "should rethrow ThreadKilled" $
|
|
runExceptT (tryAllErrors $ throwAsync ThreadKilled) `shouldThrow` (\e -> e == ThreadKilled)
|
|
it "should rethrow StackOverflow" $
|
|
runExceptT (tryAllErrors $ throwAsync StackOverflow) `shouldThrow` (\e -> e == StackOverflow)
|
|
describe "catchAllErrors" $ do
|
|
it "should catch ExceptT error" $
|
|
runExceptT (throwTestError `catchAllErrors` handleCatch) `shouldReturn` Right "caught TestError \"error\""
|
|
it "should catch SomeException" $
|
|
runExceptT (throwTestException `catchAllErrors` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
|
|
it "should not throw if there are no errors" $
|
|
runExceptT (noErrors `catchAllErrors` throwError) `shouldReturn` Right "no errors"
|
|
describe "catchThrow" $ do
|
|
it "should re-throw ExceptT error" $
|
|
runExceptT (throwTestError `catchThrow` fromSomeException) `shouldReturn` Left (TestError "error")
|
|
it "should catch SomeException and throw as ExceptT error" $
|
|
runExceptT (throwTestException `catchThrow` fromSomeException) `shouldReturn` Left (TestException "user error (error)")
|
|
it "should not throw if there are no exceptions" $
|
|
runExceptT (noErrors `catchThrow` fromSomeException) `shouldReturn` Right "no errors"
|
|
describe "allFinally should run final action" $ do
|
|
it "then throw ExceptT error" $ withFinal $ \final ->
|
|
runExceptT (throwTestError `allFinally` final) `shouldReturn` Left (TestError "error")
|
|
it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
|
|
runExceptT (throwTestException `allFinally` final) `shouldReturn` Left (TestException "user error (error)")
|
|
it "and should not throw if there are no exceptions" $ withFinal $ \final ->
|
|
runExceptT (noErrors `allFinally` final) `shouldReturn` Right "no errors"
|
|
describe "tryAllOwnErrors" $ do
|
|
it "should return ExceptT error as Left" $
|
|
runExceptT (tryAllOwnErrors throwTestError) `shouldReturn` Right (Left (TestError "error"))
|
|
it "should return SomeException as Left" $
|
|
runExceptT (tryAllOwnErrors throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
|
|
it "should catch StackOverflow" $
|
|
runExceptT (tryAllOwnErrors $ throwAsync StackOverflow) `shouldReturn` Right (Left (TestException "stack overflow"))
|
|
it "should catch HeapOverflow" $
|
|
runExceptT (tryAllOwnErrors $ throwAsync HeapOverflow) `shouldReturn` Right (Left (TestException "heap overflow"))
|
|
it "should catch AllocationLimitExceeded" $
|
|
runExceptT (tryAllOwnErrors $ throwAsync AllocationLimitExceeded) `shouldReturn` Right (Left (TestException "allocation limit exceeded"))
|
|
it "should rethrow ThreadKilled" $
|
|
runExceptT (tryAllOwnErrors $ throwAsync ThreadKilled) `shouldThrow` (\e -> e == ThreadKilled)
|
|
it "should return no errors as Right" $
|
|
runExceptT (tryAllOwnErrors noErrors) `shouldReturn` Right (Right "no errors")
|
|
describe "catchAllOwnErrors" $ do
|
|
it "should catch ExceptT error" $
|
|
runExceptT (throwTestError `catchAllOwnErrors` handleCatch) `shouldReturn` Right "caught TestError \"error\""
|
|
it "should catch SomeException" $
|
|
runExceptT (throwTestException `catchAllOwnErrors` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
|
|
it "should catch StackOverflow" $
|
|
runExceptT (throwAsync StackOverflow `catchAllOwnErrors` handleCatch) `shouldReturn` Right "caught TestException \"stack overflow\""
|
|
it "should catch HeapOverflow" $
|
|
runExceptT (throwAsync HeapOverflow `catchAllOwnErrors` handleCatch) `shouldReturn` Right "caught TestException \"heap overflow\""
|
|
it "should catch AllocationLimitExceeded" $
|
|
runExceptT (throwAsync AllocationLimitExceeded `catchAllOwnErrors` handleCatch) `shouldReturn` Right "caught TestException \"allocation limit exceeded\""
|
|
it "should rethrow ThreadKilled" $
|
|
runExceptT (throwAsync ThreadKilled `catchAllOwnErrors` handleCatch) `shouldThrow` (\e -> e == ThreadKilled)
|
|
it "should not throw if there are no errors" $
|
|
runExceptT (noErrors `catchAllOwnErrors` throwError) `shouldReturn` Right "no errors"
|
|
where
|
|
throwTestError :: ExceptT TestError IO String
|
|
throwTestError = throwError $ TestError "error"
|
|
throwTestException :: ExceptT TestError IO String
|
|
throwTestException = liftIO $ throwIO $ userError "error"
|
|
throwAsync :: Exception e => e -> ExceptT TestError IO String
|
|
throwAsync = liftIO . throwIO
|
|
noErrors :: ExceptT TestError IO String
|
|
noErrors = pure "no errors"
|
|
handleCatch :: TestError -> ExceptT TestError IO String
|
|
handleCatch e = pure $ "caught " <> show e
|
|
handleException :: SomeException -> ExceptT TestError IO String
|
|
handleException e = pure $ "caught " <> show e
|
|
withFinal :: (ExceptT TestError IO String -> IO ()) -> IO ()
|
|
withFinal test = do
|
|
r <- newIORef False
|
|
let final = liftIO $ writeIORef r True >> pure "final"
|
|
test final
|
|
readIORef r `shouldReturn` True
|
|
|
|
data TestError = TestError String | TestException String
|
|
deriving (Eq, Show)
|
|
|
|
instance Exception TestError
|
|
|
|
instance AnyError TestError where
|
|
fromSomeException = TestException . show
|