{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.Transport.Tests.Auxiliary
  ( -- Running tests
    runTest
  , runTests
    -- Writing tests
  , 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)

-- | Like fork, but throw exceptions in the child thread to the parent
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))

-- | Like try, but specialized to 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

-- | Run the given test, catching timeouts and exceptions
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 -- 60 seconds
  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

-- | Run a bunch of tests and throw an exception if any fails
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"

-- | Random thread delay between 0 and the specified max
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)

--------------------------------------------------------------------------------
-- traceShow instances                                                            --
--------------------------------------------------------------------------------

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