git.iko.soy/distributed-process
on master help sign in
Improved feedback when a test fails
2fb3b6eEdsko de Vries
network-transport-2/tests/TestAuxiliary.hs+25
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1module TestAuxiliary ( -- Running tests
2module TestAuxiliary ( -- Running tests
2 runTest
3 runTest
3 , runTests
4 , runTests
@@ -17,6 +18,8 @@ import System.Console.ANSI ( SGR(SetColor, Reset)
17 , ColorIntensity(Vivid)
18 , ColorIntensity(Vivid)
18 , setSGR
19 , setSGR
19 )
20 )
21+import Network.Transport
22+import Traced (Trace(..))
20
23
21-- | Like fork, but throw exceptions in the child thread to the parent
24-- | Like fork, but throw exceptions in the child thread to the parent
22forkTry :: IO () -> IO ThreadId
25forkTry :: IO () -> IO ThreadId
@@ -55,3 +58,25 @@ runTests :: [(String, IO ())] -> IO ()
55runTests tests = do
58runTests tests = do
56 success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
59 success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
57 unless success $ fail "Some tests failed"
60 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
32 , sClose
32 , sClose
33 , HostName
33 , HostName
34 , ServiceName
34 , ServiceName
35+ , Socket
36+ , AddrInfo
35 )
37 )
36import Network.Socket.ByteString (sendMany)
38import Network.Socket.ByteString (sendMany)
37import Data.String (fromString)
39import Data.String (fromString)
38import Traced
40import Traced
39
41
40−instance Show (MVar a) where
42+instance Trace ControlHeader where
41− show _ = "<<mvar>>"
43+ trace = Just . show
42
44
43−instance Show EndPoint where
45+instance Trace ConnectionRequestResponse where
44− show _ = "<<endpoint>>"
46+ trace = Just . show
45
47
46−instance Show Transport where
48+instance Trace N.Socket where
47− show _ = "<<transport>>"
49+ trace = const Nothing
48
50
49−instance Show Connection where
51+instance Trace N.AddrInfo where
50− show _ = "<<connection>>"
52+ trace = Just . show
51
53
52-- Test that the server gets a ConnectionClosed message when the client closes
54-- Test that the server gets a ConnectionClosed message when the client closes
53-- the socket without sending an explicit control message to the server first
55-- 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 #-}
1module TestTransport where
2module TestTransport where
2
3
3−import Prelude hiding (catch)
4+import Prelude hiding (catch, (>>=), (>>), return, fail)
4import TestAuxiliary (forkTry, runTests)
5import TestAuxiliary (forkTry, runTests)
5import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
6import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
6import Control.Monad (replicateM, replicateM_, when, guard, forM_)
7import Control.Monad (replicateM, replicateM_, when, guard, forM_)
7−import Control.Exception (evaluate, throw, catch, SomeException)
8−import Control.Applicative ((<$>))
9import Network.Transport
8import Network.Transport
10import Network.Transport.Internal (tlog)
9import Network.Transport.Internal (tlog)
11import Network.Transport.Util (spawn)
10import Network.Transport.Util (spawn)
@@ -13,6 +12,8 @@ import Data.ByteString (ByteString)
13import Data.ByteString.Char8 (pack)
12import Data.ByteString.Char8 (pack)
14import Data.Map (Map)
13import Data.Map (Map)
15import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
14import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
15+import Data.String (fromString)
16+import Traced
16
17
17-- | Server that echoes messages straight back to the origin endpoint.
18-- | Server that echoes messages straight back to the origin endpoint.
18echoServer :: EndPoint -> IO ()
19echoServer :: EndPoint -> IO ()
@@ -40,23 +41,6 @@ echoServer endpoint = do
40 ErrorEvent _ ->
41 ErrorEvent _ ->
41 fail (show event)
42 fail (show event)
42
43
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−
60-- | Ping client used in a few tests
44-- | Ping client used in a few tests
61ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
45ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
62ping endpoint server numPings msg = do
46ping endpoint server numPings msg = do
@@ -66,13 +50,14 @@ ping endpoint server numPings msg = do
66
50
67 -- Wait for the server to open reply connection
51 -- Wait for the server to open reply connection
68 tlog "Wait for ConnectionOpened message"
52 tlog "Wait for ConnectionOpened message"
69− cid <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
53+ ConnectionOpened cid _ _ <- receive endpoint
70
54
71 -- Send pings and wait for reply
55 -- Send pings and wait for reply
72 tlog "Send ping and wait for reply"
56 tlog "Send ping and wait for reply"
73 replicateM_ numPings $ do
57 replicateM_ numPings $ do
74 send conn [msg]
58 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 ()
76
61
77 -- Close the connection
62 -- Close the connection
78 tlog "Close the connection"
63 tlog "Close the connection"
@@ -80,7 +65,7 @@ ping endpoint server numPings msg = do
80
65
81 -- Wait for the server to close its connection to us
66 -- Wait for the server to close its connection to us
82 tlog "Wait for ConnectionClosed message"
67 tlog "Wait for ConnectionClosed message"
83− expect' endpoint (\(ConnectionClosed cid') -> cid == cid')
68+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
84
69
85 -- Done
70 -- Done
86 tlog "Ping client done"
71 tlog "Ping client done"
@@ -431,11 +416,11 @@ testCloseTwice transport _ = do
431 close conn1
416 close conn1
432
417
433 -- Verify expected response from the echo server
418 -- Verify expected response from the echo server
434− cid1 <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
419+ ConnectionOpened cid1 _ _ <- receive endpoint
435− cid2 <- expect endpoint (\(ConnectionOpened cid _ _) -> (True, cid))
420+ ConnectionOpened cid2 _ _ <- receive endpoint
436− expect' endpoint (\(ConnectionClosed cid) -> cid == cid2)
421+ ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
437− expect' endpoint (\(Received cid msg) -> cid == cid1 && msg == ["ping"])
422+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
438− expect' endpoint (\(ConnectionClosed cid) -> cid == cid1)
423+ ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
439
424
440 putMVar clientDone ()
425 putMVar clientDone ()
441
426
@@ -467,19 +452,65 @@ testConnectToSelf transport numPings = do
467 tlog $ "reading"
452 tlog $ "reading"
468
453
469 tlog "Waiting for ConnectionOpened"
454 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
471
456
472 tlog "Waiting for Received"
457 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 ()
474
461
475 tlog "Waiting for ConnectionClosed"
462 tlog "Waiting for ConnectionClosed"
476− expect' endpoint (\(ConnectionClosed cid') -> cid == cid')
463+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
477
464
478 tlog "Done"
465 tlog "Done"
479 putMVar done ()
466 putMVar done ()
480
467
481 takeMVar done
468 takeMVar done
482
469
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
483
514
484-- Transport tests
515-- Transport tests
485testTransport :: Transport -> IO ()
516testTransport :: Transport -> IO ()
@@ -494,6 +525,7 @@ testTransport transport = runTests
494 , ("SendAfterClose", testSendAfterClose transport numPings)
525 , ("SendAfterClose", testSendAfterClose transport numPings)
495 , ("CloseTwice", testCloseTwice transport numPings)
526 , ("CloseTwice", testCloseTwice transport numPings)
496 , ("ConnectToSelf", testConnectToSelf transport numPings)
527 , ("ConnectToSelf", testConnectToSelf transport numPings)
528+ , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
497 ]
529 ]
498 where
530 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 #-}
1+{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances #-}
2−-- | Add "tracing" to the IO monad (see examples).
2+-- | Add tracing to the IO monad (see examples).
3--
3--
4-- [Usage]
4-- [Usage]
5--
5--
@@ -46,31 +46,38 @@ module Traced ( MonadS(..)
46 , (>>=)
46 , (>>=)
47 , (>>)
47 , (>>)
48 , fail
48 , fail
49+ , ifThenElse
50+ , Trace(..)
49 ) where
51 ) where
50
52
51import Prelude hiding ((>>=), return, fail, catch, (>>))
53import Prelude hiding ((>>=), return, fail, catch, (>>))
52import qualified Prelude
54import qualified Prelude
53import Data.String (fromString)
55import Data.String (fromString)
54−import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..))
56+import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..), IOException)
55import Data.Typeable (Typeable)
57import 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)
56
63
57--------------------------------------------------------------------------------
64--------------------------------------------------------------------------------
58-- MonadS class --
65-- MonadS class --
59--------------------------------------------------------------------------------
66--------------------------------------------------------------------------------
60
67
61−-- | Like 'Monad' but bind is only defined for 'Showable' instances
68+-- | Like 'Monad' but bind is only defined for 'Trace'able instances
62class MonadS m where
69class MonadS m where
63 returnS :: a -> m a
70 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
65 failS :: String -> m a
72 failS :: String -> m a
66 seqS :: m a -> m b -> m b
73 seqS :: m a -> m b -> m b
67
74
68-- | Redefinition of 'Prelude.>>='
75-- | 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
70(>>=) = bindS
77(>>=) = bindS
71
78
72-- | Redefinition of 'Prelude.>>'
79-- | Redefinition of 'Prelude.>>'
73−(>>) :: (MonadS m, Show a) => m a -> m b -> m b
80+(>>) :: MonadS m => m a -> m b -> m b
74(>>) = seqS
81(>>) = seqS
75
82
76-- | Redefinition of 'Prelude.return'
83-- | Redefinition of 'Prelude.return'
@@ -81,6 +88,64 @@ return = returnS
81fail :: MonadS m => String -> m a
88fail :: MonadS m => String -> m a
82fail = failS
89fail = failS
83
90
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+
84--------------------------------------------------------------------------------
149--------------------------------------------------------------------------------
85-- IO instance for MonadS --
150-- IO instance for MonadS --
86--------------------------------------------------------------------------------
151--------------------------------------------------------------------------------
@@ -98,11 +163,17 @@ instance MonadS IO where
98 seqS = (Prelude.>>)
163 seqS = (Prelude.>>)
99
164
100instance Show TracedException where
165instance Show TracedException where
101− show (TracedException trace ex) =
166+ show (TracedException ts ex) =
102− show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse trace)))
167+ show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse ts)))
103−
168+
104−traceHandlers :: Show a => a -> [Handler b]
169+traceHandlers :: Trace a => a -> [Handler b]
105−traceHandlers a =
170+traceHandlers a = case trace a of
171+ Nothing -> [ Handler $ \(ex :: SomeException) -> throw ex ]
106− [ Handler $ \(TracedException trace ex) -> throw $ TracedException (show a : trace) ex
172+ Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (t : ts) ex
107− , Handler $ \(ex :: SomeException) -> throw $ TracedException [show a] ex
173+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [t] ex
108− ]
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