{-# 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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
p (\SomeException
e -> ThreadId -> SomeException -> IO ()
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 = IO a -> IO (Either SomeException a)
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Running " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
description [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
Handle -> IO ()
hFlush Handle
stdout
Either SomeException (Maybe ())
done <- IO (Maybe ()) -> IO (Either SomeException (Maybe ()))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe ()) -> IO (Either SomeException (Maybe ())))
-> (IO () -> IO (Maybe ()))
-> IO ()
-> IO (Either SomeException (Maybe ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
60000000 (IO () -> IO (Either SomeException (Maybe ())))
-> IO () -> IO (Either SomeException (Maybe ()))
forall a b. (a -> b) -> a -> b
$ IO ()
test
case Either SomeException (Maybe ())
done of
Left SomeException
err -> [Char] -> IO Bool
failed ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"(exception: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show (SomeException
err :: SomeException) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
Right Maybe ()
Nothing -> [Char] -> IO Bool
failed ([Char] -> IO Bool) -> [Char] -> IO Bool
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
Bool -> IO Bool
forall a. a -> IO a
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]
Bool -> IO Bool
forall a. a -> IO a
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 <- (([Char], IO ()) -> IO Bool -> IO Bool)
-> IO Bool -> [([Char], IO ())] -> IO Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Bool -> Bool -> Bool) -> IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (IO Bool -> IO Bool -> IO Bool)
-> (([Char], IO ()) -> IO Bool)
-> ([Char], IO ())
-> IO Bool
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO () -> IO Bool) -> ([Char], IO ()) -> IO Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> IO () -> IO Bool
runTest) (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ([([Char], IO ())] -> IO Bool) -> [([Char], IO ())] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [([Char], IO ())]
tests
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. [Char] -> IO a
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 <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int
Int -> IO ()
threadDelay (Int
delay Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
maxDelay)
instance Traceable EndPoint where
trace :: EndPoint -> Maybe Showable
trace = Maybe Showable -> EndPoint -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing
instance Traceable Transport where
trace :: Transport -> Maybe Showable
trace = Maybe Showable -> Transport -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing
instance Traceable Connection where
trace :: Connection -> Maybe Showable
trace = Maybe Showable -> Connection -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing
instance Traceable Event where
trace :: Event -> Maybe Showable
trace = Event -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow
instance Show err => Traceable (TransportError err) where
trace :: TransportError err -> Maybe Showable
trace = TransportError err -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow
instance Traceable EndPointAddress where
trace :: EndPointAddress -> Maybe Showable
trace = ByteString -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (ByteString -> Maybe Showable)
-> (EndPointAddress -> ByteString)
-> EndPointAddress
-> Maybe Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndPointAddress -> ByteString
endPointAddressToByteString
instance Traceable SomeException where
trace :: SomeException -> Maybe Showable
trace = SomeException -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow
instance Traceable ThreadId where
trace :: ThreadId -> Maybe Showable
trace = Maybe Showable -> ThreadId -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing
instance Traceable (Chan a) where
trace :: Chan a -> Maybe Showable
trace = Maybe Showable -> Chan a -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing
instance Traceable Float where
trace :: Float -> Maybe Showable
trace = Float -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow