git.iko.soy/distributed-process
on master help sign in
Improved feedback when a test fails
commit2fb3b6eb5adc053eac8423efa0c96c4a8a8f0a65 authorEdsko de Vries <edsko@edsko.net> dateSat 12 May 2012, 11:18 (14 years ago) parentebec48f
4 files changed+185−55
compare with master
unifiedsplit
network-transport-2/tests/TestAuxiliary.hs+25 network-transport-2/tests/TestTCP.hs+10−8 network-transport-2/tests/TestTransport.hs+64−32 network-transport-2/tests/Traced.hs+86−15
network-transport-2/tests/TestAuxiliary.hs+25
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12module TestAuxiliary ( -- Running tests
23 runTest
34 , runTests
@@ -17,6 +18,8 @@ import System.Console.ANSI ( SGR(SetColor, Reset)
1718 , ColorIntensity(Vivid)
1819 , setSGR
1920 )
21+import Network.Transport
22+import Traced (Trace(..))
2023
2124-- | Like fork, but throw exceptions in the child thread to the parent
2225forkTry :: IO () -> IO ThreadId
@@ -55,3 +58,25 @@ runTests :: [(String, IO ())] -> IO ()
5558runTests tests = do
5659 success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
5760 unless success $ fail "Some tests failed"
61+
62+--------------------------------------------------------------------------------
63+-- Trace instances --
64+--------------------------------------------------------------------------------
65+
66+instance Trace EndPoint where
67+ trace = const Nothing
68+
69+instance Trace Transport where
70+ trace = const Nothing
71+
72+instance Trace Connection where
73+ trace = const Nothing
74+
75+instance Trace Event where
76+ trace = Just . show
77+
78+instance Show err => Trace (FailedWith err) where
79+ trace = Just . show
80+
81+instance Trace EndPointAddress where
82+ trace = trace .endPointAddressToByteString
network-transport-2/tests/TestTCP.hs+10−8
@@ -32,22 +32,24 @@ import qualified Network.Socket as N ( getAddrInfo
3232 , sClose
3333 , HostName
3434 , ServiceName
35+ , Socket
36+ , AddrInfo
3537 )
3638import Network.Socket.ByteString (sendMany)
3739import Data.String (fromString)
3840import Traced
3941
40−instance Show (MVar a) where
41− show _ = "<<mvar>>"
42+instance Trace ControlHeader where
43+ trace = Just . show
4244
43−instance Show EndPoint where
44− show _ = "<<endpoint>>"
45+instance Trace ConnectionRequestResponse where
46+ trace = Just . show
4547
46−instance Show Transport where
47− show _ = "<<transport>>"
48+instance Trace N.Socket where
49+ trace = const Nothing
4850
49−instance Show Connection where
50− show _ = "<<connection>>"
51+instance Trace N.AddrInfo where
52+ trace = Just . show
5153
5254-- Test that the server gets a ConnectionClosed message when the client closes
5355-- the socket without sending an explicit control message to the server first
network-transport-2/tests/TestTransport.hs+64−32
@@ -1,11 +1,10 @@
1+{-# LANGUAGE RebindableSyntax, FlexibleInstances, OverlappingInstances, UndecidableInstances #-}
12module TestTransport where
23
3−import Prelude hiding (catch)
4+import Prelude hiding (catch, (>>=), (>>), return, fail)
45import TestAuxiliary (forkTry, runTests)
56import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
67import Control.Monad (replicateM, replicateM_, when, guard, forM_)
7−import Control.Exception (evaluate, throw, catch, SomeException)
8−import Control.Applicative ((<$>))
98import Network.Transport
109import Network.Transport.Internal (tlog)
1110import Network.Transport.Util (spawn)
@@ -13,6 +12,8 @@ import Data.ByteString (ByteString)
1312import Data.ByteString.Char8 (pack)
1413import Data.Map (Map)
1514import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
15+import Data.String (fromString)
16+import Traced
1617
1718-- | Server that echoes messages straight back to the origin endpoint.
1819echoServer :: EndPoint -> IO ()
@@ -40,23 +41,6 @@ echoServer endpoint = do
4041 ErrorEvent _ ->
4142 fail (show event)
4243
43−-- | Wait for an event, throw an exception if the given predicate returns false
44−expect :: EndPoint -> (Event -> (Bool, a)) -> IO a
45−expect endpoint predicate = do
46− event <- receive endpoint
47− mbool <- catch (Right <$> evaluate (predicate event)) (return . Left)
48− case mbool of
49− Left err -> do tlog $ "Unexpected event " ++ show event
50− throw (err :: SomeException)
51− Right (False, _) -> do tlog $ "Unexpected event " ++ show event
52− fail "Unexpected event"
53− Right (True, a) -> return a
54−
55−-- | Like 'expect' but without a return value
56−expect' :: EndPoint -> (Event -> Bool) -> IO ()
57−expect' endpoint predicate =
58− expect endpoint (\event -> (predicate event, ()))
59−
6044-- | Ping client used in a few tests
6145ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
6246ping endpoint server numPings msg = do
@@ -66,13 +50,14 @@ ping endpoint server numPings msg = do
6650
6751 -- Wait for the server to open reply connection
6852 tlog "Wait for ConnectionOpened message"
69− cid <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
53+ ConnectionOpened cid _ _ <- receive endpoint
7054
7155 -- Send pings and wait for reply
7256 tlog "Send ping and wait for reply"
7357 replicateM_ numPings $ do
7458 send conn [msg]
75− expect' endpoint (\(Received cid' [reply]) -> cid == cid' && reply == msg)
59+ Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg
60+ return ()
7661
7762 -- Close the connection
7863 tlog "Close the connection"
@@ -80,7 +65,7 @@ ping endpoint server numPings msg = do
8065
8166 -- Wait for the server to close its connection to us
8267 tlog "Wait for ConnectionClosed message"
83− expect' endpoint (\(ConnectionClosed cid') -> cid == cid')
68+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
8469
8570 -- Done
8671 tlog "Ping client done"
@@ -431,11 +416,11 @@ testCloseTwice transport _ = do
431416 close conn1
432417
433418 -- Verify expected response from the echo server
434− cid1 <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
435− cid2 <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
436− expect' endpoint (\(ConnectionClosed cid) -> cid == cid2)
437− expect' endpoint (\(Received cid msg) -> cid == cid1 && msg == ["ping"])
438− expect' endpoint (\(ConnectionClosed cid) -> cid == cid1)
419+ ConnectionOpened cid1 _ _ <- receive endpoint
420+ ConnectionOpened cid2 _ _ <- receive endpoint
421+ ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
422+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
423+ ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
439424
440425 putMVar clientDone ()
441426
@@ -467,19 +452,65 @@ testConnectToSelf transport numPings = do
467452 tlog $ "reading"
468453
469454 tlog "Waiting for ConnectionOpened"
470− cid <- expect endpoint (\(ConnectionOpened cid _ addr) -> (addr == address endpoint, cid))
455+ ConnectionOpened cid _ addr <- receive endpoint ; True <- return $ addr == address endpoint
471456
472457 tlog "Waiting for Received"
473− replicateM_ numPings $ expect' endpoint (\(Received cid' msg) -> cid == cid' && msg == ["ping"])
458+ replicateM_ numPings $ do
459+ Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
460+ return ()
474461
475462 tlog "Waiting for ConnectionClosed"
476− expect' endpoint (\(ConnectionClosed cid') -> cid == cid')
463+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
477464
478465 tlog "Done"
479466 putMVar done ()
480467
481468 takeMVar done
482469
470+-- | Test that we can connect an endpoint to itself multiple times
471+testConnectToSelfTwice :: Transport -> Int -> IO ()
472+testConnectToSelfTwice transport numPings = do
473+ done <- newEmptyMVar
474+ Right endpoint <- newEndPoint transport
475+
476+ tlog "Creating self-connection"
477+ Right conn1 <- connect endpoint (address endpoint) ReliableOrdered
478+ Right conn2 <- connect endpoint (address endpoint) ReliableOrdered
479+
480+ tlog "Talk to myself"
481+
482+ -- One thread to write to the endpoint using the first connection
483+ forkTry $ do
484+ tlog $ "writing"
485+
486+ tlog $ "Sending ping"
487+ replicateM_ numPings $ send conn1 ["pingA"]
488+
489+ tlog $ "Closing connection"
490+ close conn1
491+
492+ -- One thread to write to the endpoint using the second connection
493+ forkTry $ do
494+ tlog $ "writing"
495+
496+ tlog $ "Sending ping"
497+ replicateM_ numPings $ send conn2 ["pingB"]
498+
499+ tlog $ "Closing connection"
500+ close conn2
501+
502+ -- And one thread to read
503+ forkTry $ do
504+ tlog $ "reading"
505+
506+ [(_, events1), (_, events2)] <- collect endpoint (2 * (numPings + 2))
507+ True <- return $ events1 == replicate numPings ["pingA"]
508+ True <- return $ events2 == replicate numPings ["pingB"]
509+
510+ tlog "Done"
511+ putMVar done ()
512+
513+ takeMVar done
483514
484515-- Transport tests
485516testTransport :: Transport -> IO ()
@@ -494,6 +525,7 @@ testTransport transport = runTests
494525 , ("SendAfterClose", testSendAfterClose transport numPings)
495526 , ("CloseTwice", testCloseTwice transport numPings)
496527 , ("ConnectToSelf", testConnectToSelf transport numPings)
528+ , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
497529 ]
498530 where
499− numPings = 10000
531+ numPings = 10000 :: Int
network-transport-2/tests/Traced.hs+86−15
@@ -1,5 +1,5 @@
1−{-# LANGUAGE RebindableSyntax, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, DeriveDataTypeable #-}
2−-- | Add "tracing" to the IO monad (see examples).
1+{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances #-}
2+-- | Add tracing to the IO monad (see examples).
33--
44-- [Usage]
55--
@@ -46,31 +46,38 @@ module Traced ( MonadS(..)
4646 , (>>=)
4747 , (>>)
4848 , fail
49+ , ifThenElse
50+ , Trace(..)
4951 ) where
5052
5153import Prelude hiding ((>>=), return, fail, catch, (>>))
5254import qualified Prelude
5355import Data.String (fromString)
54−import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..))
56+import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..), IOException)
5557import Data.Typeable (Typeable)
58+import Data.Maybe (catMaybes)
59+import Data.List (intersperse)
60+import Data.ByteString (ByteString)
61+import Data.Int (Int32)
62+import Control.Concurrent.MVar (MVar)
5663
5764--------------------------------------------------------------------------------
5865-- MonadS class --
5966--------------------------------------------------------------------------------
6067
61−-- | Like 'Monad' but bind is only defined for 'Showable' instances
68+-- | Like 'Monad' but bind is only defined for 'Trace'able instances
6269class MonadS m where
6370 returnS :: a -> m a
64− bindS :: Show a => m a -> (a -> m b) -> m b
71+ bindS :: Trace a => m a -> (a -> m b) -> m b
6572 failS :: String -> m a
6673 seqS :: m a -> m b -> m b
6774
6875-- | Redefinition of 'Prelude.>>='
69−(>>=) :: (MonadS m, Show a) => m a -> (a -> m b) -> m b
76+(>>=) :: (MonadS m, Trace a) => m a -> (a -> m b) -> m b
7077(>>=) = bindS
7178
7279-- | Redefinition of 'Prelude.>>'
73−(>>) :: (MonadS m, Show a) => m a -> m b -> m b
80+(>>) :: MonadS m => m a -> m b -> m b
7481(>>) = seqS
7582
7683-- | Redefinition of 'Prelude.return'
@@ -81,6 +88,64 @@ return = returnS
8188fail :: MonadS m => String -> m a
8289fail = failS
8390
91+--------------------------------------------------------------------------------
92+-- Trace typeclass (for adding elements to a trace --
93+--------------------------------------------------------------------------------
94+
95+-- | Used to add a term to the trace
96+class Trace a where
97+ -- | Return 'Nothing' not to add the term to the trace
98+ trace :: a -> Maybe String
99+
100+instance (Trace a, Trace b) => Trace (Either a b) where
101+ trace (Left x) = trace x
102+ trace (Right y) = trace y
103+
104+instance Trace a => Trace [a] where
105+ trace as = Just $ "[" ++ (concat . intersperse "," . catMaybes . map trace $ as) ++ "]"
106+
107+instance (Trace a, Trace b) => Trace (a, b) where
108+ trace (x, y) = case (trace x, trace y) of
109+ (Nothing, Nothing) -> Nothing
110+ (Just t1, Nothing) -> Just t1
111+ (Nothing, Just t2) -> Just t2
112+ (Just t1, Just t2) -> Just $ "(" ++ t1 ++ ", " ++ t2 ++ ")"
113+
114+instance (Trace a, Trace b, Trace c) => Trace (a, b, c) where
115+ trace (x, y, z) = case (trace x, trace y, trace z) of
116+ (Nothing, Nothing, Nothing) -> Nothing
117+ (Just t1, Nothing, Nothing) -> Just t1
118+ (Nothing, Just t2, Nothing) -> Just t2
119+ (Nothing, Nothing, Just t3) -> Just t3
120+ (Just t1, Just t2, Nothing) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ ")"
121+ (Just t1, Nothing, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t3 ++ ")"
122+ (Nothing, Just t2, Just t3) -> Just $ "(" ++ t2 ++ "," ++ t3 ++ ")"
123+ (Just t1, Just t2, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ "," ++ t2 ++ "," ++ t3 ++ ")"
124+
125+instance Trace () where
126+ trace = const Nothing
127+
128+instance Trace Int where
129+ trace = Just . show
130+
131+instance Trace Int32 where
132+ trace = Just . show
133+
134+instance Trace Bool where
135+ trace = const Nothing
136+
137+instance Trace ByteString where
138+ trace = Just . show
139+
140+instance Trace (MVar a) where
141+ trace = const Nothing
142+
143+instance Trace [Char] where
144+ trace = Just . show
145+
146+instance Trace IOException where
147+ trace = Just . show
148+
84149--------------------------------------------------------------------------------
85150-- IO instance for MonadS --
86151--------------------------------------------------------------------------------
@@ -98,11 +163,17 @@ instance MonadS IO where
98163 seqS = (Prelude.>>)
99164
100165instance Show TracedException where
101− show (TracedException trace ex) =
102− show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse trace)))
103−
104−traceHandlers :: Show a => a -> [Handler b]
105−traceHandlers a =
106− [ Handler $ \(TracedException trace ex) -> throw $ TracedException (show a : trace) ex
107− , Handler $ \(ex :: SomeException) -> throw $ TracedException [show a] ex
108− ]
166+ show (TracedException ts ex) =
167+ show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse ts)))
168+
169+traceHandlers :: Trace a => a -> [Handler b]
170+traceHandlers a = case trace a of
171+ Nothing -> [ Handler $ \(ex :: SomeException) -> throw ex ]
172+ Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (t : ts) ex
173+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [t] ex
174+ ]
175+
176+-- | Definition of 'ifThenElse' for use with RebindableSyntax
177+ifThenElse :: Bool -> a -> a -> a
178+ifThenElse True x _ = x
179+ifThenElse False _ y = y