git.iko.soy/distributed-process
on master help sign in
Merge branch 'showy-exit-messages'
d225580Tim Watson
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+9−1
compare with master
unifiedsplit
@@ -377,7 +377,15 @@ data ProcessExitException =
377
377
378instance Exception ProcessExitException
378instance Exception ProcessExitException
379instance Show ProcessExitException where
379instance Show ProcessExitException where
380+ show = showProcessExit
381+
382+showProcessExit :: ProcessExitException -> String
380− show (ProcessExitException pid _) = "exit-from=" ++ show pid
383+showProcessExit (ProcessExitException pid reason) =
384+ case messageFingerprint reason == fingerprint (undefined :: String) of
385+ True -> "origin=" ++ (show pid) ++ ",reason=" ++ decoded
386+ False -> "origin=" ++ show pid
387+ where decoded :: String
388+ !decoded = decode (messageEncoding reason)
381
389
382-- | Catches ProcessExitException
390-- | Catches ProcessExitException
383catchExit :: forall a b . (Show a, Serializable a)
391catchExit :: forall a b . (Show a, Serializable a)
distributed-process/tests/TestCH.hs+18
@@ -33,6 +33,7 @@ import Control.Distributed.Process.Internal.Types
33 , LocalNode(localEndPoint)
33 , LocalNode(localEndPoint)
34 )
34 )
35import Control.Distributed.Process.Node
35import Control.Distributed.Process.Node
36+import Control.Distributed.Process.Internal.Primitives
36import Control.Distributed.Process.Serializable (Serializable)
37import Control.Distributed.Process.Serializable (Serializable)
37
38
38import Test.HUnit (Assertion)
39import Test.HUnit (Assertion)
@@ -908,6 +909,22 @@ testDie transport = do
908
909
909 takeMVar done
910 takeMVar done
910
911
912+testPrettyExit :: NT.Transport -> Assertion
913+testPrettyExit transport = do
914+ localNode <- newLocalNode transport initRemoteTable
915+ done <- newEmptyMVar
916+
917+ _ <- forkProcess localNode $ do
918+ (die "timeout")
919+ `catch` \ex@(ProcessExitException from _) ->
920+ let expected = "origin=" ++ (show from) ++
921+ ",reason=timeout"
922+ in do
923+ True <- return $ (show ex) == expected
924+ liftIO $ putMVar done ()
925+
926+ takeMVar done
927+
911testExitLocal :: NT.Transport -> Assertion
928testExitLocal :: NT.Transport -> Assertion
912testExitLocal transport = do
929testExitLocal transport = do
913 localNode <- newLocalNode transport initRemoteTable
930 localNode <- newLocalNode transport initRemoteTable
@@ -976,6 +993,7 @@ tests (transport, transportInternals) = [
976 , testCase "KillLocal" (testKillLocal transport)
993 , testCase "KillLocal" (testKillLocal transport)
977 , testCase "KillRemote" (testKillRemote transport)
994 , testCase "KillRemote" (testKillRemote transport)
978 , testCase "Die" (testDie transport)
995 , testCase "Die" (testDie transport)
996+ , testCase "PrettyExit" (testPrettyExit transport)
979 , testCase "ExitLocal" (testExitLocal transport)
997 , testCase "ExitLocal" (testExitLocal transport)
980 , testCase "ExitRemote" (testExitRemote transport)
998 , testCase "ExitRemote" (testExitRemote transport)
981 ]
999 ]