{-# OPTIONS_GHC -Wno-orphans #-}

-- | Test the real networking layer
module Hydra.NetworkSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Codec.CBOR.Read (deserialiseFromBytes)
import Codec.CBOR.Write (toLazyByteString)
import Control.Concurrent.Class.MonadSTM (modifyTVar', newTQueue, newTVarIO, readTQueue, readTVarIO, writeTQueue)
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (nullTracer, showLogsOnFailure)
import Hydra.Network (Host (..), Network, NetworkCallback (..))
import Hydra.Network.Message (
  HydraHandshakeRefused (..),
  HydraVersionedProtocolNumber (..),
  Message (..),
 )
import Hydra.Network.Ouroboros (HydraNetworkConfig (..), broadcast, withOuroborosNetwork)
import Hydra.Network.Reliability (MessagePersistence (..))
import Hydra.Node.Network (configureMessagePersistence)
import Hydra.Node.ParameterMismatch (ParameterMismatch)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Network.Ports (randomUnusedTCPPorts)
import Test.QuickCheck (
  Property,
  (===),
 )
import Test.QuickCheck.Instances.ByteString ()

spec :: Spec
spec :: Spec
spec = do
  let lo :: Text
lo = Text
"127.0.0.1"

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Ouroboros Network" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"broadcasts messages to single connected peer" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      TQueue IO Integer
received <- STM IO (TQueue IO Integer) -> IO (TQueue IO Integer)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Integer)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      let recordReceived :: NetworkCallback Integer IO
recordReceived = NetworkCallback{$sel:deliver:NetworkCallback :: Integer -> IO ()
deliver = STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ()) -> (Integer -> STM ()) -> Integer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue IO Integer -> Integer -> STM IO ()
forall a. TQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue IO Integer
received}
      Text
-> (Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
-> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NetworkSpec" ((Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
 -> IO ())
-> (Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
30 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [PortNumber
port1, PortNumber
port2] <- (Int -> PortNumber) -> [Int] -> [PortNumber]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [PortNumber]) -> IO [Int] -> IO [PortNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO [Int]
randomUnusedTCPPorts Int
2
        let node1Config :: HydraNetworkConfig
node1Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port1
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port2]
                }
            node2Config :: HydraNetworkConfig
node2Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port2
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port1]
                }
        forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork @Integer Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer HydraNetworkConfig
node1Config (IO () -> HydraHandshakeRefused -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraHandshakeRefused -> IO ())
-> IO () -> HydraHandshakeRefused -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) NetworkCallback Integer IO
forall (m :: * -> *) msg. Applicative m => NetworkCallback msg m
mockCallback ((Network IO Integer -> IO ()) -> IO ())
-> (Network IO Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Integer
hn1 ->
          forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork @Integer Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer HydraNetworkConfig
node2Config (IO () -> HydraHandshakeRefused -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraHandshakeRefused -> IO ())
-> IO () -> HydraHandshakeRefused -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) NetworkCallback Integer IO
recordReceived ((Network IO Integer -> IO ()) -> IO ())
-> (Network IO Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Integer
_ -> do
            Network IO Integer -> Integer -> IO () -> IO ()
forall b. Network IO Integer -> Integer -> IO b -> IO b
withNodeBroadcastingForever Network IO Integer
hn1 Integer
1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              STM IO Integer -> IO Integer
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Integer -> STM IO Integer
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO Integer
received) IO Integer -> Integer -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Integer
1

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"handshake failures should call the handshakeCallback" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Text
-> (Tracer IO (WithHost (TraceOuroborosNetwork Int)) -> IO ())
-> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NetworkSpec" ((Tracer IO (WithHost (TraceOuroborosNetwork Int)) -> IO ())
 -> IO ())
-> (Tracer IO (WithHost (TraceOuroborosNetwork Int)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (WithHost (TraceOuroborosNetwork Int))
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
30 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [PortNumber
port1, PortNumber
port2] <- (Int -> PortNumber) -> [Int] -> [PortNumber]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [PortNumber]) -> IO [Int] -> IO [PortNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO [Int]
randomUnusedTCPPorts Int
2
        let node1Config :: HydraNetworkConfig
node1Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port1
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port2]
                }
            node2Config :: HydraNetworkConfig
node2Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
1
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port2
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port1]
                }
            createHandshakeCallback :: IO (HydraHandshakeRefused -> IO (), IO [Host])
            createHandshakeCallback :: IO (HydraHandshakeRefused -> IO (), IO [Host])
createHandshakeCallback = do
              TVar [Host]
x <- [Host] -> IO (TVar IO [Host])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
              let f :: HydraHandshakeRefused -> IO ()
f (HydraHandshakeRefused{Host
remoteHost :: Host
$sel:remoteHost:HydraHandshakeRefused :: HydraHandshakeRefused -> Host
remoteHost}) = STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO [Host] -> ([Host] -> [Host]) -> 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 [Host]
TVar IO [Host]
x (Host
remoteHost :)
              let g :: IO [Host]
g = TVar IO [Host] -> IO [Host]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar [Host]
TVar IO [Host]
x
              (HydraHandshakeRefused -> IO (), IO [Host])
-> IO (HydraHandshakeRefused -> IO (), IO [Host])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraHandshakeRefused -> IO ()
f, IO [Host]
g)

        (HydraHandshakeRefused -> IO ()
handshakeCallback1, IO [Host]
getHandshakeFailures1) <- IO (HydraHandshakeRefused -> IO (), IO [Host])
createHandshakeCallback
        (HydraHandshakeRefused -> IO ()
handshakeCallback2, IO [Host]
getHandshakeFailures2) <- IO (HydraHandshakeRefused -> IO (), IO [Host])
createHandshakeCallback

        forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork @Int @Int Tracer IO (WithHost (TraceOuroborosNetwork Int))
tracer HydraNetworkConfig
node1Config HydraHandshakeRefused -> IO ()
handshakeCallback1 NetworkCallback Int IO
forall (m :: * -> *) msg. Applicative m => NetworkCallback msg m
mockCallback ((Network IO Int -> IO ()) -> IO ())
-> (Network IO Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Int
_ ->
          forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork @Int Tracer IO (WithHost (TraceOuroborosNetwork Int))
tracer HydraNetworkConfig
node2Config HydraHandshakeRefused -> IO ()
handshakeCallback2 NetworkCallback Int IO
forall (m :: * -> *) msg. Applicative m => NetworkCallback msg m
mockCallback ((Network IO Int -> IO ()) -> IO ())
-> (Network IO Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Int
_ -> do
            DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
            IO [Host]
getHandshakeFailures1 IO [Host] -> [Host] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Text -> PortNumber -> Host
Host Text
lo PortNumber
port2]
            IO [Host]
getHandshakeFailures2 IO [Host] -> [Host] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Text -> PortNumber -> Host
Host Text
lo PortNumber
port1]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"broadcasts messages between 3 connected peers" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      TQueue IO Integer
node1received <- STM IO (TQueue IO Integer) -> IO (TQueue IO Integer)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Integer)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      TQueue IO Integer
node2received <- STM IO (TQueue IO Integer) -> IO (TQueue IO Integer)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Integer)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      TQueue IO Integer
node3received <- STM IO (TQueue IO Integer) -> IO (TQueue IO Integer)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Integer)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      let recordReceivedIn :: TQueue m msg -> NetworkCallback msg m
recordReceivedIn TQueue m msg
tq = NetworkCallback{$sel:deliver:NetworkCallback :: msg -> m ()
deliver = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (msg -> STM m ()) -> msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue m msg -> msg -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m msg
tq}
      Text
-> (Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
-> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NetworkSpec" ((Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
 -> IO ())
-> (Tracer IO (WithHost (TraceOuroborosNetwork Integer)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
30 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [PortNumber
port1, PortNumber
port2, PortNumber
port3] <- (Int -> PortNumber) -> [Int] -> [PortNumber]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [PortNumber]) -> IO [Int] -> IO [PortNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO [Int]
randomUnusedTCPPorts Int
3
        let node1Config :: HydraNetworkConfig
node1Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port1
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port2, Text -> PortNumber -> Host
Host Text
lo PortNumber
port3]
                }
            node2Config :: HydraNetworkConfig
node2Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port2
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port1, Text -> PortNumber -> Host
Host Text
lo PortNumber
port3]
                }
            node3Config :: HydraNetworkConfig
node3Config =
              HydraNetworkConfig
                { $sel:protocolVersion:HydraNetworkConfig :: HydraVersionedProtocolNumber
protocolVersion = Natural -> HydraVersionedProtocolNumber
MkHydraVersionedProtocolNumber Natural
0
                , $sel:localHost:HydraNetworkConfig :: Host
localHost = Text -> PortNumber -> Host
Host Text
lo PortNumber
port3
                , $sel:remoteHosts:HydraNetworkConfig :: [Host]
remoteHosts = [Text -> PortNumber -> Host
Host Text
lo PortNumber
port2, Text -> PortNumber -> Host
Host Text
lo PortNumber
port1]
                }
        forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork @Integer Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer HydraNetworkConfig
node1Config (IO () -> HydraHandshakeRefused -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraHandshakeRefused -> IO ())
-> IO () -> HydraHandshakeRefused -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (TQueue IO Integer -> NetworkCallback Integer IO
forall {m :: * -> *} {msg}.
MonadSTM m =>
TQueue m msg -> NetworkCallback msg m
recordReceivedIn TQueue IO Integer
node1received) ((Network IO Integer -> IO ()) -> IO ())
-> (Network IO Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Integer
hn1 ->
          Tracer IO (WithHost (TraceOuroborosNetwork Integer))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO Integer Integer ()
forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer HydraNetworkConfig
node2Config (IO () -> HydraHandshakeRefused -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraHandshakeRefused -> IO ())
-> IO () -> HydraHandshakeRefused -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (TQueue IO Integer -> NetworkCallback Integer IO
forall {m :: * -> *} {msg}.
MonadSTM m =>
TQueue m msg -> NetworkCallback msg m
recordReceivedIn TQueue IO Integer
node2received) ((Network IO Integer -> IO ()) -> IO ())
-> (Network IO Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Integer
hn2 -> do
            Tracer IO (WithHost (TraceOuroborosNetwork Integer))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO Integer Integer ()
forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork Tracer IO (WithHost (TraceOuroborosNetwork Integer))
tracer HydraNetworkConfig
node3Config (IO () -> HydraHandshakeRefused -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraHandshakeRefused -> IO ())
-> IO () -> HydraHandshakeRefused -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (TQueue IO Integer -> NetworkCallback Integer IO
forall {m :: * -> *} {msg}.
MonadSTM m =>
TQueue m msg -> NetworkCallback msg m
recordReceivedIn TQueue IO Integer
node3received) ((Network IO Integer -> IO ()) -> IO ())
-> (Network IO Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO Integer
hn3 -> do
              [(Network IO Integer, Integer)] -> IO () -> IO ()
forall b. [(Network IO Integer, Integer)] -> IO b -> IO b
withNodesBroadcastingForever [(Network IO Integer
hn1, Integer
1), (Network IO Integer
hn2, Integer
2), (Network IO Integer
hn3, Integer
3)] (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                [(TQueue IO Integer, Integer)] -> IO ()
assertAllnodesReceivedMessagesFromAllOtherNodes [(TQueue IO Integer
node1received, Integer
1), (TQueue IO Integer
node2received, Integer
2), (TQueue IO Integer
node3received, Integer
3)]

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Serialisation" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> (Message SimpleTx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"can roundtrip CBOR encoding/decoding of Hydra Message" ((Message SimpleTx -> Property) -> Spec)
-> (Message SimpleTx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ forall a. (ToCBOR a, FromCBOR a, Eq a, Show a) => a -> Property
prop_canRoundtripCBOREncoding @(Message SimpleTx)
    Proxy (Message SimpleTx) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Message SimpleTx))

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"configureMessagePersistence" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throws ParameterMismatch when configuring given number of acks does not match number of parties" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
String -> (String -> m r) -> m r
withTempDir String
"persistence" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
        MessagePersistence{Vector Int -> IO ()
saveAcks :: Vector Int -> IO ()
$sel:saveAcks:MessagePersistence :: forall (m :: * -> *) msg.
MessagePersistence m msg -> Vector Int -> m ()
saveAcks} <- forall (m :: * -> *) msg tx.
(MonadIO m, MonadThrow m, FromJSON msg, ToJSON msg, MonadSTM m,
 MonadThread m, MonadThrow (STM m)) =>
Tracer m (HydraNodeLog tx)
-> String -> Int -> m (MessagePersistence m msg)
configureMessagePersistence @_ @Int Tracer IO (HydraNodeLog Any)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer String
dir Int
3
        Vector Int -> IO ()
saveAcks ([Item (Vector Int)] -> Vector Int
forall l. IsList l => [Item l] -> l
fromList [Int
Item (Vector Int)
0, Int
Item (Vector Int)
0, Int
Item (Vector Int)
0])
        forall (m :: * -> *) msg tx.
(MonadIO m, MonadThrow m, FromJSON msg, ToJSON msg, MonadSTM m,
 MonadThread m, MonadThrow (STM m)) =>
Tracer m (HydraNodeLog tx)
-> String -> Int -> m (MessagePersistence m msg)
configureMessagePersistence @_ @Int Tracer IO (HydraNodeLog Any)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer String
dir Int
4 IO (MessagePersistence IO Int)
-> Selector ParameterMismatch -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` (Bool -> Selector ParameterMismatch
forall a b. a -> b -> a
const Bool
True :: Selector ParameterMismatch)

withNodeBroadcastingForever :: Network IO Integer -> Integer -> IO b -> IO b
withNodeBroadcastingForever :: forall b. Network IO Integer -> Integer -> IO b -> IO b
withNodeBroadcastingForever Network IO Integer
node Integer
value = [(Network IO Integer, Integer)] -> IO b -> IO b
forall b. [(Network IO Integer, Integer)] -> IO b -> IO b
withNodesBroadcastingForever [(Network IO Integer
node, Integer
value)]

withNodesBroadcastingForever :: [(Network IO Integer, Integer)] -> IO b -> IO b
withNodesBroadcastingForever :: forall b. [(Network IO Integer, Integer)] -> IO b -> IO b
withNodesBroadcastingForever [] IO b
continuation = IO b
continuation
withNodesBroadcastingForever ((Network IO Integer
node, Integer
value) : [(Network IO Integer, Integer)]
rest) IO b
continuation =
  IO Any -> (Async IO Any -> IO b) -> IO b
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
    (IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Network IO Integer -> Integer -> IO ()
forall (m :: * -> *) msg. Network m msg -> msg -> m ()
broadcast Network IO Integer
node Integer
value)
    ((Async IO Any -> IO b) -> IO b) -> (Async IO Any -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Async IO Any
_ -> [(Network IO Integer, Integer)] -> IO b -> IO b
forall b. [(Network IO Integer, Integer)] -> IO b -> IO b
withNodesBroadcastingForever [(Network IO Integer, Integer)]
rest IO b
continuation

assertAllnodesReceivedMessagesFromAllOtherNodes :: [(TQueue IO Integer, Integer)] -> IO ()
assertAllnodesReceivedMessagesFromAllOtherNodes :: [(TQueue IO Integer, Integer)] -> IO ()
assertAllnodesReceivedMessagesFromAllOtherNodes [(TQueue IO Integer, Integer)]
messagesFromNodes =
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [ TQueue IO Integer -> Integer -> IO ()
shouldEventuallyReceive TQueue Integer
TQueue IO Integer
thisQueue Integer
otherValue
    | (TQueue Integer
thisQueue, Integer
thisValue) <- [(TQueue Integer, Integer)]
[(TQueue IO Integer, Integer)]
messagesFromNodes
    , (TQueue Integer
_otherQueue, Integer
otherValue) <- [(TQueue Integer, Integer)]
[(TQueue IO Integer, Integer)]
messagesFromNodes
    , Integer
otherValue Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
thisValue
    ]

shouldEventuallyReceive :: TQueue IO Integer -> Integer -> Expectation
shouldEventuallyReceive :: TQueue IO Integer -> Integer -> IO ()
shouldEventuallyReceive TQueue IO Integer
queue Integer
expectedValue = do
  Integer
receivedValue <- STM IO Integer -> IO Integer
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO Integer -> IO Integer) -> STM IO Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ TQueue IO Integer -> STM IO Integer
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO Integer
queue
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
receivedValue Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
expectedValue) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue IO Integer -> Integer -> IO ()
shouldEventuallyReceive TQueue IO Integer
queue Integer
expectedValue

prop_canRoundtripCBOREncoding ::
  (ToCBOR a, FromCBOR a, Eq a, Show a) => a -> Property
prop_canRoundtripCBOREncoding :: forall a. (ToCBOR a, FromCBOR a, Eq a, Show a) => a -> Property
prop_canRoundtripCBOREncoding a
a =
  let encoded :: ByteString
encoded = Encoding -> ByteString
toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
a
   in ((ByteString, a) -> a
forall a b. (a, b) -> b
snd ((ByteString, a) -> a)
-> Either DeserialiseFailure (ByteString, a)
-> Either DeserialiseFailure a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR ByteString
encoded) Either DeserialiseFailure a
-> Either DeserialiseFailure a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a -> Either DeserialiseFailure a
forall a b. b -> Either a b
Right a
a

mockCallback :: Applicative m => NetworkCallback msg m
mockCallback :: forall (m :: * -> *) msg. Applicative m => NetworkCallback msg m
mockCallback = NetworkCallback{$sel:deliver:NetworkCallback :: msg -> m ()
deliver = \msg
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}