{-# 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 (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))

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

-- | 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 ([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 -- 60 seconds
  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

-- | 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 <- (([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"

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

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

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