{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.Transport.Tests.Auxiliary
(
runTest
, runTests
, forkTry
, trySome
, randomThreadDelay
) where
#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
import Control.Concurrent.Chan (Chan)
import Control.Monad (liftM2, unless)
import Control.Exception (SomeException, try, catch)
import System.Timeout (timeout)
import System.IO (stdout, hFlush)
import System.Console.ANSI ( SGR(SetColor, Reset)
, Color(Red, Green)
, ConsoleLayer(Foreground)
, ColorIntensity(Vivid)
, setSGR
)
import System.Random (randomIO)
import Network.Transport
import Network.Transport.Tests.Traced (Traceable(..), traceShow)
forkTry :: IO () -> IO ThreadId
forkTry :: IO () -> IO ThreadId
forkTry IO ()
p = do
ThreadId
tid <- IO ThreadId
myThreadId
IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
p (\SomeException
e -> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (SomeException
e :: SomeException))
trySome :: IO a -> IO (Either SomeException a)
trySome :: forall a. IO a -> IO (Either SomeException a)
trySome = forall e a. Exception e => IO a -> IO (Either e a)
try
runTest :: String -> IO () -> IO Bool
runTest :: [Char] -> IO () -> IO Bool
runTest [Char]
description IO ()
test = do
[Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [Char]
"Running " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
description forall a. [a] -> [a] -> [a]
++ [Char]
": "
Handle -> IO ()
hFlush Handle
stdout
Either SomeException (Maybe ())
done <- forall e a. Exception e => IO a -> IO (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IO a -> IO (Maybe a)
timeout Int
60000000 forall a b. (a -> b) -> a -> b
$ IO ()
test
case Either SomeException (Maybe ())
done of
Left SomeException
err -> [Char] -> IO Bool
failed forall a b. (a -> b) -> a -> b
$ [Char]
"(exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (SomeException
err :: SomeException) forall a. [a] -> [a] -> [a]
++ [Char]
")"
Right Maybe ()
Nothing -> [Char] -> IO Bool
failed forall a b. (a -> b) -> a -> b
$ [Char]
"(timeout)"
Right (Just ()) -> IO Bool
ok
where
failed :: String -> IO Bool
failed :: [Char] -> IO Bool
failed [Char]
err = do
[SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red]
[Char] -> IO ()
putStr [Char]
"failed "
[SGR] -> IO ()
setSGR [SGR
Reset]
[Char] -> IO ()
putStrLn [Char]
err
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ok :: IO Bool
ok :: IO Bool
ok = do
[SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green]
[Char] -> IO ()
putStrLn [Char]
"ok"
[SGR] -> IO ()
setSGR [SGR
Reset]
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
runTests :: [(String, IO ())] -> IO ()
runTests :: [([Char], IO ())] -> IO ()
runTests [([Char], IO ())]
tests = do
Bool
success <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> IO () -> IO Bool
runTest) (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall a b. (a -> b) -> a -> b
$ [([Char], IO ())]
tests
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Some tests failed"
randomThreadDelay :: Int -> IO ()
randomThreadDelay :: Int -> IO ()
randomThreadDelay Int
maxDelay = do
Int
delay <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int
Int -> IO ()
threadDelay (Int
delay forall a. Integral a => a -> a -> a
`mod` Int
maxDelay)
instance Traceable EndPoint where
trace :: EndPoint -> Maybe Showable
trace = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Traceable Transport where
trace :: Transport -> Maybe Showable
trace = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Traceable Connection where
trace :: Connection -> Maybe Showable
trace = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Traceable Event where
trace :: Event -> Maybe Showable
trace = forall a. Show a => a -> Maybe Showable
traceShow
instance Show err => Traceable (TransportError err) where
trace :: TransportError err -> Maybe Showable
trace = forall a. Show a => a -> Maybe Showable
traceShow
instance Traceable EndPointAddress where
trace :: EndPointAddress -> Maybe Showable
trace = forall a. Show a => a -> Maybe Showable
traceShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndPointAddress -> ByteString
endPointAddressToByteString
instance Traceable SomeException where
trace :: SomeException -> Maybe Showable
trace = forall a. Show a => a -> Maybe Showable
traceShow
instance Traceable ThreadId where
trace :: ThreadId -> Maybe Showable
trace = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Traceable (Chan a) where
trace :: Chan a -> Maybe Showable
trace = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Traceable Float where
trace :: Float -> Maybe Showable
trace = forall a. Show a => a -> Maybe Showable
traceShow