{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Network.TxSubmission.AppV1 (tests) where

import Prelude hiding (seq)

import NoThunks.Class

import Control.Concurrent.Class.MonadMVar (MonadMVar)
import Control.Concurrent.Class.MonadSTM
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim hiding (SimResult)
import Control.Tracer (Tracer (..), contramap, nullTracer)

import Data.ByteString.Lazy qualified as BSL
import Data.Function (on)
import Data.List (intercalate, nubBy)
import Data.Maybe (fromMaybe)
import Data.Word (Word16)

import Cardano.Network.NodeToNode (NodeToNodeVersion (..))

import Ouroboros.Network.Channel
import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM)
import Ouroboros.Network.Driver
import Ouroboros.Network.Protocol.TxSubmission2.Client
import Ouroboros.Network.Protocol.TxSubmission2.Codec
import Ouroboros.Network.Protocol.TxSubmission2.Server
import Ouroboros.Network.Protocol.TxSubmission2.Type
import Ouroboros.Network.TxSubmission.Inbound.V1
import Ouroboros.Network.TxSubmission.Outbound
import Ouroboros.Network.Util.ShowProxy

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

import Test.Ouroboros.Network.TxSubmission.Types
import Test.Ouroboros.Network.Utils


tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"AppV1"
  [ TestName
-> (Positive Word16
    -> NonEmptyList (Tx Int)
    -> Maybe (Positive SmallDelay)
    -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"txSubmission" Positive Word16
-> NonEmptyList (Tx Int) -> Maybe (Positive SmallDelay) -> Property
prop_txSubmission
  ]

txSubmissionSimulation
  :: forall m txid.
     ( MonadAsync m
     , MonadDelay m
     , MonadFork  m
     , MonadMask  m
     , MonadMVar  m
     , MonadSay   m
     , MonadST    m
     , MonadSTM   m
     , MonadTimer m
     , MonadThrow m
     , MonadThrow (STM m)
     , MonadMonotonicTime m
     , Ord txid
     , Eq  txid
     , ShowProxy txid
     , NoThunks (Tx txid)

     , txid ~ Int
     )
  => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid)))
  -> NumTxIdsToAck
  -> [Tx txid]
  -> ControlMessageSTM m
  -> Maybe DiffTime
  -> Maybe DiffTime
  -> m ([Tx txid], [Tx txid])
txSubmissionSimulation :: forall (m :: * -> *) txid.
(MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, MonadMVar m,
 MonadSay m, MonadST m, MonadSTM m, MonadTimer m, MonadThrow m,
 MonadThrow (STM m), MonadMonotonicTime m, Ord txid, Eq txid,
 ShowProxy txid, NoThunks (Tx txid), txid ~ Int) =>
Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
-> NumTxIdsToAck
-> [Tx txid]
-> ControlMessageSTM m
-> Maybe DiffTime
-> Maybe DiffTime
-> m ([Tx txid], [Tx txid])
txSubmissionSimulation Tracer m (TestName, TraceSendRecv (TxSubmission2 txid (Tx txid)))
tracer NumTxIdsToAck
maxUnacked [Tx txid]
outboundTxs
                       ControlMessageSTM m
controlMessageSTM
                       Maybe DiffTime
inboundDelay Maybe DiffTime
outboundDelay = do

    inboundMempool  <- m (Mempool m (Tx txid))
forall (m :: * -> *) txid. MonadSTM m => m (Mempool m (Tx txid))
emptyMempool
    outboundMempool <- newMempool outboundTxs
    (outboundChannel, inboundChannel) <- createConnectedChannels
    outboundAsync <-
      async $ runPeerWithLimits
                (("OUTBOUND",) `contramap` tracer)
                txSubmissionCodec2
                (byteLimitsTxSubmission2 (fromIntegral . BSL.length))
                timeLimitsTxSubmission2
                (maybe id delayChannel outboundDelay outboundChannel)
                (txSubmissionClientPeer (outboundPeer outboundMempool))

    inboundAsync <-
      async $ runPipelinedPeerWithLimits
                (("INBOUND",) `contramap` verboseTracer)
                txSubmissionCodec2
                (byteLimitsTxSubmission2 (fromIntegral . BSL.length))
                timeLimitsTxSubmission2
                (maybe id delayChannel inboundDelay inboundChannel)
                (txSubmissionServerPeerPipelined (inboundPeer inboundMempool))

    _ <- waitAnyCancel [ outboundAsync, inboundAsync ]

    inmp <- readMempool inboundMempool
    outmp <- readMempool outboundMempool
    return (inmp, outmp)
  where

    outboundPeer :: Mempool m (Tx txid) -> TxSubmissionClient txid (Tx txid) m ()
    outboundPeer :: Mempool m (Tx txid) -> TxSubmissionClient txid (Tx txid) m ()
outboundPeer Mempool m (Tx txid)
outboundMempool =
      Tracer m (TraceTxSubmissionOutbound txid (Tx txid))
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid (Tx txid) Int m
-> NodeToNodeVersion
-> ControlMessageSTM m
-> TxSubmissionClient txid (Tx txid) m ()
forall version txid tx idx (m :: * -> *).
(Ord txid, Ord idx, MonadSTM m, MonadThrow m) =>
Tracer m (TraceTxSubmissionOutbound txid tx)
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid tx idx m
-> version
-> ControlMessageSTM m
-> TxSubmissionClient txid tx m ()
txSubmissionOutbound
        Tracer m (TraceTxSubmissionOutbound txid (Tx txid))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        NumTxIdsToAck
maxUnacked
        (Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Eq txid, Show txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
getMempoolReader Mempool m (Tx txid)
outboundMempool)
        (NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion)
        ControlMessageSTM m
controlMessageSTM

    inboundPeer :: Mempool m (Tx txid) -> TxSubmissionServerPipelined txid (Tx txid) m ()
    inboundPeer :: Mempool m (Tx txid)
-> TxSubmissionServerPipelined txid (Tx txid) m ()
inboundPeer Mempool m (Tx txid)
inboundMempool =
      Tracer m (TraceTxSubmissionInbound txid (Tx txid))
-> TxSubmissionInitDelay
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid (Tx txid) Int m
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
-> NodeToNodeVersion
-> TxSubmissionServerPipelined txid (Tx txid) m ()
forall txid tx idx (m :: * -> *).
(Ord txid, NoThunks txid, NoThunks tx, MonadSTM m, MonadThrow m,
 MonadDelay m) =>
Tracer m (TraceTxSubmissionInbound txid tx)
-> TxSubmissionInitDelay
-> NumTxIdsToAck
-> TxSubmissionMempoolReader txid tx idx m
-> TxSubmissionMempoolWriter txid tx idx m
-> NodeToNodeVersion
-> TxSubmissionServerPipelined txid tx m ()
txSubmissionInbound
        Tracer m (TraceTxSubmissionInbound txid (Tx txid))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        TxSubmissionInitDelay
NoTxSubmissionInitDelay
        NumTxIdsToAck
maxUnacked
        (Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Eq txid, Show txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolReader txid (Tx txid) Int m
getMempoolReader Mempool m (Tx txid)
inboundMempool)
        (Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
forall txid (m :: * -> *).
(MonadSTM m, Ord txid, Eq txid) =>
Mempool m (Tx txid)
-> TxSubmissionMempoolWriter txid (Tx txid) Int m
getMempoolWriter Mempool m (Tx txid)
inboundMempool)
        (NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion)

prop_txSubmission :: Positive Word16
                  -> NonEmptyList (Tx Int)
                  -> Maybe (Positive SmallDelay)
                  -- ^ The delay must be smaller (<) than 5s, so that overall
                  -- delay is less than 10s, otherwise 'smallDelay' in
                  -- 'timeLimitsTxSubmission2' will kick in.
                  -> Property
prop_txSubmission :: Positive Word16
-> NonEmptyList (Tx Int) -> Maybe (Positive SmallDelay) -> Property
prop_txSubmission (Positive Word16
maxUnacked) (NonEmpty [Tx Int]
outboundTxs) Maybe (Positive SmallDelay)
delay =
    let mbDelayTime :: Maybe DiffTime
mbDelayTime = SmallDelay -> DiffTime
getSmallDelay (SmallDelay -> DiffTime)
-> (Positive SmallDelay -> SmallDelay)
-> Positive SmallDelay
-> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive SmallDelay -> SmallDelay
forall a. Positive a -> a
getPositive (Positive SmallDelay -> DiffTime)
-> Maybe (Positive SmallDelay) -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Positive SmallDelay)
delay
        tr :: SimTrace ([Tx Int], [Tx Int])
tr = ((forall s. IOSim s ([Tx Int], [Tx Int]))
-> SimTrace ([Tx Int], [Tx Int])
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace ((forall s. IOSim s ([Tx Int], [Tx Int]))
 -> SimTrace ([Tx Int], [Tx Int]))
-> (forall s. IOSim s ([Tx Int], [Tx Int]))
-> SimTrace ([Tx Int], [Tx Int])
forall a b. (a -> b) -> a -> b
$ do
            controlMessageVar <- ControlMessage -> IOSim s (TVar (IOSim s) ControlMessage)
forall a. a -> IOSim s (TVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO ControlMessage
Continue
            _ <-
              async $ do
                threadDelay
                  (fromMaybe 1 mbDelayTime
                    * realToFrac (length outboundTxs `div` 4))
                atomically (writeTVar controlMessageVar Terminate)
            txSubmissionSimulation
              verboseTracer
              (NumTxIdsToAck maxUnacked) outboundTxs
              (readTVar controlMessageVar)
              mbDelayTime mbDelayTime
            ) in
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        tr' <- SimTrace ([Tx Int], [Tx Int])
-> IO (SimResults ([Tx Int], [Tx Int]))
forall a. SimTrace a -> IO (SimResults a)
evaluateTrace SimTrace ([Tx Int], [Tx Int])
tr
        case tr' of
             SimException SomeException
e [TestName]
trace -> do
                Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"\n" ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ SomeException -> TestName
forall a. Show a => a -> TestName
show SomeException
e TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: [TestName]
trace) Bool
False
             SimDeadLock [TestName]
trace -> do
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"\n" ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ TestName
"Deadlock" TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: [TestName]
trace) Bool
False
             SimReturn ([Tx Int]
inmp, [Tx Int]
outmp) [TestName]
_trace -> do
                 -- printf "Log: %s\n" (intercalate "\n" _trace)
                 let outUniqueTxIds :: [Tx Int]
outUniqueTxIds = (Tx Int -> Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((Int -> Int -> Bool) -> (Tx Int -> Int) -> Tx Int -> Tx Int -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Tx Int -> Int
forall txid. Tx txid -> txid
getTxId) [Tx Int]
outmp
                     outValidTxs :: [Tx Int]
outValidTxs    = (Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Tx Int -> Bool
forall txid. Tx txid -> Bool
getTxValid [Tx Int]
outmp
                 case ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outUniqueTxIds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outmp, [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outValidTxs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
outmp) of
                      (Bool
True, Bool
True) ->
                          -- If we are presented with a stream of unique txids for valid
                          -- transactions the inbound transactions should match the outbound
                          -- transactions exactly.
                          Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [Tx Int]
inmp [Tx Int] -> [Tx Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> [Tx Int] -> [Tx Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp) [Tx Int]
outValidTxs
                      (Bool
True, Bool
False) ->
                          -- If we are presented with a stream of unique txids then we should have
                          -- fetched all valid transactions.
                          Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [Tx Int]
inmp [Tx Int] -> [Tx Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> [Tx Int] -> [Tx Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp) [Tx Int]
outValidTxs
                      (Bool
False, Bool
True) ->
                          -- If we are presented with a stream of valid txids then we should have
                          -- fetched some version of those transactions.
                          Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ (Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId [Tx Int]
inmp [Int] -> [Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
inmp) ((Tx Int -> Int) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tx Int -> Int
forall txid. Tx txid -> txid
getTxId ([Tx Int] -> [Int]) -> [Tx Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
                              (Tx Int -> Bool) -> [Tx Int] -> [Tx Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Tx Int -> Bool
forall txid. Tx txid -> Bool
getTxValid [Tx Int]
outUniqueTxIds)
                      (Bool
False, Bool
False)
                           -- If we are presented with a stream of valid and invalid Txs with
                           -- duplicate txids we're content with completing the protocol
                           -- without error.
                           -> Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True