{-# OPTIONS_GHC -Wno-deprecations #-}

module Test.Util where

import Hydra.Prelude
import Test.Hydra.Prelude hiding (shouldBe)

import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
import Control.Monad.Class.MonadSay (say)
import Control.Monad.IOSim (
  Failure (FailureException),
  IOSim,
  SimTrace,
  runSimTrace,
  selectTraceEventsDynamic',
  traceM,
  traceResult,
 )
import Control.Tracer (Tracer (Tracer))
import Data.Aeson (encode)
import Data.Aeson qualified as Aeson
import Data.Text qualified as Text
import Hydra.Ledger.Simple (SimpleTx)
import Hydra.Network (NetworkCallback (..))
import Hydra.Node (HydraNodeLog)
import Test.HUnit.Lang (FailureReason (ExpectedButGot))
import Test.QuickCheck (forAll, withMaxSuccess)

noopCallback :: Applicative m => NetworkCallback msg m
noopCallback :: forall (m :: * -> *) msg. Applicative m => NetworkCallback msg m
noopCallback =
  NetworkCallback
    { $sel:deliver:NetworkCallback :: msg -> m ()
deliver = \msg
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:onConnectivity:NetworkCallback :: Connectivity -> m ()
onConnectivity = m () -> Connectivity -> m ()
forall a b. a -> b -> a
const (m () -> Connectivity -> m ()) -> m () -> Connectivity -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

-- | Run given 'action' in 'IOSim' and rethrow any exceptions.
shouldRunInSim ::
  (forall s. IOSim s a) ->
  IO a
shouldRunInSim :: forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim forall s. IOSim s a
action =
  case Bool -> SimTrace a -> Either Failure a
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
False SimTrace a
tr of
    Right a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Left (FailureException (SomeException e
ex)) -> do
      IO ()
dumpTrace
      e -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
ex
    Left Failure
ex -> do
      IO ()
dumpTrace
      Failure -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Failure
ex
 where
  tr :: SimTrace a
tr = (forall s. IOSim s a) -> SimTrace a
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s a
forall s. IOSim s a
action
  dumpTrace :: IO ()
dumpTrace = String -> IO ()
forall (m :: * -> *). MonadSay m => String -> m ()
say (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Proxy (HydraNodeLog SimpleTx) -> SimTrace a -> Text
forall log a.
(Typeable log, ToJSON log) =>
Proxy log -> SimTrace a -> Text
printTrace (Proxy (HydraNodeLog SimpleTx)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (HydraNodeLog SimpleTx)) SimTrace a
tr)

-- | Utility function to dump logs given a `SimTrace`.
printTrace :: forall log a. (Typeable log, ToJSON log) => Proxy log -> SimTrace a -> Text
printTrace :: forall log a.
(Typeable log, ToJSON log) =>
Proxy log -> SimTrace a -> Text
printTrace Proxy log
_ SimTrace a
tr =
  [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> ([log] -> [Text]) -> [log] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (log -> Text) -> [log] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (log -> ByteString) -> log -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. log -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode) ([log] -> Text) -> [log] -> Text
forall a b. (a -> b) -> a -> b
$
    forall a b. Typeable b => Trace a SimEvent -> [b]
selectTraceEventsDynamic' @_ @log SimTrace a
tr

-- | Lifted variant of Hspec's 'shouldBe'.
shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldBe :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
shouldBe a
actual a
expected =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    HUnitFailure -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HUnitFailure -> m ()) -> HUnitFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location FailureReason
reason
 where
  reason :: FailureReason
reason = Maybe String -> String -> String -> FailureReason
ExpectedButGot Maybe String
forall a. Maybe a
Nothing (a -> String
forall b a. (Show a, IsString b) => a -> b
show a
expected) (a -> String
forall b a. (Show a, IsString b) => a -> b
show a
actual)

-- | Lifted variant of Hspec's 'shouldNotBe'.
shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldNotBe :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
shouldNotBe a
actual a
expected
  | a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
expected = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"not expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
actual

-- | Lifted variant of Hspec's 'shouldSatisfy'.
shouldSatisfy :: (HasCallStack, MonadThrow m, Show a) => a -> (a -> Bool) -> m ()
a
v shouldSatisfy :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` a -> Bool
p =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a -> Bool
p a
v) (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"predicate failed on: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall b a. (Show a, IsString b) => a -> b
show a
v

-- | A 'Tracer' that works in 'IOSim' monad.
-- This tracer uses the 'Output' event which uses converts value traced to 'Dynamic'
-- which requires 'Typeable' constraint. To retrieve the trace use 'selectTraceEventsDynamic'
-- applied to the correct type.
traceInIOSim :: Typeable a => Tracer (IOSim s) a
traceInIOSim :: forall a s. Typeable a => Tracer (IOSim s) a
traceInIOSim = (a -> IOSim s ()) -> Tracer (IOSim s) a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer a -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM

-- | Useful when one needs to /also/ trace logs to `stderr`.
-- Thanks to the monoidal nature of `Tracer` it's straightforward to add this to
-- any existing tracer:
--
-- @@
-- someCode tracer = do
--   foo <- makeFoo
--   withTracer (tr <> traceDebug) SomeTraceFoo
-- ...
-- @@
traceDebug :: (Applicative m, ToJSON a) => Tracer m a
traceDebug :: forall (m :: * -> *) a. (Applicative m, ToJSON a) => Tracer m a
traceDebug = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\a
a -> String -> m () -> m ()
forall a. String -> a -> a
trace (ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | This creates an hspec test case about a property which ensures the given generator
-- does not produce equals values within a reasonable number of generated values.
propCollisionResistant :: (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant :: forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
name Gen a
gen =
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is reasonably collision resistant") (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
100_000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \a
a ->
        Gen a -> (a -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen ((a -> Bool) -> Property) -> (a -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \a
b ->
          a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b

-- | Predicate which decides whether given list is continuous.
isContinuous :: (Eq a, Enum a) => [a] -> Bool
isContinuous :: forall a. (Eq a, Enum a) => [a] -> Bool
isContinuous = \case
  [] -> Bool
True
  [a
_] -> Bool
True
  (a
a : a
b : [a]
as) -> a -> a
forall a. Enum a => a -> a
succ a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& [a] -> Bool
forall a. (Eq a, Enum a) => [a] -> Bool
isContinuous (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)

-- | Predicate which decides whether given list is strictly monotonic.
isStrictlyMonotonic :: Ord a => [a] -> Bool
isStrictlyMonotonic :: forall a. Ord a => [a] -> Bool
isStrictlyMonotonic = \case
  [] -> Bool
True
  [a
_] -> Bool
True
  (a
a : a
b : [a]
as) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Ord a => [a] -> Bool
isStrictlyMonotonic (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)

-- | Wait up to some time for a function to yield an equal value.
waitEq :: (HasCallStack, Eq a, Show a) => IO a -> NominalDiffTime -> a -> IO ()
waitEq :: forall a.
(HasCallStack, Eq a, Show a) =>
IO a -> NominalDiffTime -> a -> IO ()
waitEq IO a
waitNext NominalDiffTime
delay a
expected =
  IO a -> NominalDiffTime -> (a -> Maybe ()) -> IO ()
forall a b.
(HasCallStack, Show a) =>
IO a -> NominalDiffTime -> (a -> Maybe b) -> IO b
waitMatch IO a
waitNext NominalDiffTime
delay (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected))

-- | Wait up to some time for a function to return a value that satisfies given predicate.
waitMatch :: (HasCallStack, Show a) => IO a -> NominalDiffTime -> (a -> Maybe b) -> IO b
waitMatch :: forall a b.
(HasCallStack, Show a) =>
IO a -> NominalDiffTime -> (a -> Maybe b) -> IO b
waitMatch IO a
waitNext NominalDiffTime
delay a -> Maybe b
match = do
  TVar [a]
seenMsgs <- [a] -> IO (TVar IO [a])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  DiffTime -> IO b -> IO (Maybe b)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
delay) (TVar [a] -> IO b
go TVar [a]
seenMsgs) IO (Maybe b) -> (Maybe b -> IO b) -> IO b
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just b
x -> b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
    Maybe b
Nothing -> do
      [a]
msgs <- TVar IO [a] -> IO [a]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar [a]
TVar IO [a]
seenMsgs
      String -> IO b
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO b) -> String -> IO b
forall a b. (a -> b) -> a -> b
$
        Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
            [ Text
"waitMatch did not match a message within " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
forall b a. (Show a, IsString b) => a -> b
show NominalDiffTime
delay
            , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  seen messages:"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Int -> [Text] -> [Text]
align Int
20 (a -> Text
forall b a. (Show a, IsString b) => a -> b
show (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
msgs))
            ]
 where
  go :: TVar [a] -> IO b
go TVar [a]
seenMsgs = do
    a
msg <- IO a
waitNext
    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar IO [a] -> ([a] -> [a]) -> STM IO ()
forall a. TVar IO a -> (a -> a) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar [a]
TVar IO [a]
seenMsgs (a
msg :))
    IO b -> (b -> IO b) -> Maybe b -> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TVar [a] -> IO b
go TVar [a]
seenMsgs) b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe b
match a
msg)

  align :: Int -> [Text] -> [Text]
align Int
_ [] = []
  align Int
n (Text
h : [Text]
q) = Text
h Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
Text.replicate Int
n Text
" " <>) [Text]
q