{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Test-only impairment shims for 'TxSubmissionClient'. They wrap an
-- existing outbound peer with behavioural faults at the typed-protocol
-- level: 'delayBodies' adds latency to body replies, 'omitBodies' drops
-- bodies probabilistically. Both pass txid replies through unchanged so
-- the impaired peer still advertises promptly.
--
-- The wrappers are polymorphic in @txid@ and @tx@ and depend only on the
-- TxSubmission2 client types.
module Test.Ouroboros.Network.TxSubmission.Impaired
  ( delayBodies
  , omitBodies
  , extraTxIds
  , unrequestedTx
  , Impairment (..)
  , noImpairment
  , validImpairment
  , applyImpairment
  , genOneImpairment
  , shrinkImpairment
  , kindOf
  ) where

import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, StrictTVar,
           atomically, newTVarIO, stateTVar)
import Control.Monad (filterM)
import Control.Monad.Class.MonadTime.SI (DiffTime)
import Control.Monad.Class.MonadTimer.SI (MonadDelay, threadDelay)
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (isJust)
import Data.Word (Word16)
import System.Random (StdGen, mkStdGen, uniformR)

import Ouroboros.Network.Protocol.TxSubmission2.Client
import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..))
import Ouroboros.Network.SizeInBytes (SizeInBytes)

import Test.QuickCheck (Gen, arbitrary, choose, oneof, shrink)


-- | Add a fixed delay before every 'MsgReplyTxs' (body reply); txid
-- replies pass through unchanged. Models a peer that advertises promptly
-- but is slow to deliver bodies.
--
-- The wrapper is recursive: every 'ClientStIdle' continuation produced
-- by the inner peer is wrapped in turn, so the delay applies to every
-- body reply through the protocol session - not just the first.
delayBodies
  :: forall txid tx m a.
     MonadDelay m
  => DiffTime
  -> TxSubmissionClient txid tx m a
  -> TxSubmissionClient txid tx m a
delayBodies :: forall txid tx (m :: * -> *) a.
MonadDelay m =>
DiffTime
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
delayBodies DiffTime
d (TxSubmissionClient m (ClientStIdle txid tx m a)
mIdle) =
    m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
TxSubmissionClient (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle (ClientStIdle txid tx m a -> ClientStIdle txid tx m a)
-> m (ClientStIdle txid tx m a) -> m (ClientStIdle txid tx m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle txid tx m a)
mIdle)
  where
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle { forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds, [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs } = ClientStIdle
      { recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds = \SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req -> do
          reply <- SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req
          pure (wrapTxIds reply)
      , recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs   = \[txid]
txids -> do
          reply <- [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs [txid]
txids
          threadDelay d
          pure (wrapTxs reply)
      }

    wrapTxIds :: ClientStTxIds blocking txid tx m a
              -> ClientStTxIds blocking txid tx m a
    wrapTxIds :: forall (blocking :: StBlockingStyle).
ClientStTxIds blocking txid tx m a
-> ClientStTxIds blocking txid tx m a
wrapTxIds (SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply ClientStIdle txid tx m a
k) = BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
forall (blocking :: StBlockingStyle) txid tx (m :: * -> *) a.
BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)
    wrapTxIds (SendMsgDone a
a)             = a -> ClientStTxIds 'StBlocking txid tx m a
forall a txid tx (m :: * -> *).
a -> ClientStTxIds 'StBlocking txid tx m a
SendMsgDone a
a

    wrapTxs :: ClientStTxs txid tx m a -> ClientStTxs txid tx m a
    wrapTxs :: ClientStTxs txid tx m a -> ClientStTxs txid tx m a
wrapTxs (SendMsgReplyTxs [tx]
txs ClientStIdle txid tx m a
k) = [tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
forall tx txid (m :: * -> *) a.
[tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
SendMsgReplyTxs [tx]
txs (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)


-- | Drop each body in 'MsgReplyTxs' independently with the given
-- probability; txid replies pass through unchanged. Models a peer whose
-- mempool evicts entries between advertise and fetch - the receiver sees
-- a body list that is a subset of what it requested.
--
-- Randomness is threaded through a 'StrictTVar' so the test can seed it
-- from a QuickCheck-generated value and produce reproducible drop
-- patterns. Each body is decided independently.
--
-- Recursive in the same way as 'delayBodies'.
omitBodies
  :: forall txid tx m a.
     MonadSTM m
  => StrictTVar m StdGen
  -> Double
  -- ^ drop probability for each body, in [0, 1]
  -> TxSubmissionClient txid tx m a
  -> TxSubmissionClient txid tx m a
omitBodies :: forall txid tx (m :: * -> *) a.
MonadSTM m =>
StrictTVar m StdGen
-> Double
-> TxSubmissionClient txid tx m a
-> TxSubmissionClient txid tx m a
omitBodies StrictTVar m StdGen
genVar Double
p (TxSubmissionClient m (ClientStIdle txid tx m a)
mIdle) =
    m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
TxSubmissionClient (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle (ClientStIdle txid tx m a -> ClientStIdle txid tx m a)
-> m (ClientStIdle txid tx m a) -> m (ClientStIdle txid tx m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle txid tx m a)
mIdle)
  where
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle { forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds, [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs } = ClientStIdle
      { recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds = \SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req -> do
          reply <- SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req
          pure (wrapTxIds reply)
      , recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs   = \[txid]
txids -> do
          SendMsgReplyTxs txs k <- [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs [txid]
txids
          kept <- atomically (filterM (const rollKeep) txs)
          pure (SendMsgReplyTxs kept (wrapIdle k))
      }

    wrapTxIds :: ClientStTxIds blocking txid tx m a
              -> ClientStTxIds blocking txid tx m a
    wrapTxIds :: forall (blocking :: StBlockingStyle).
ClientStTxIds blocking txid tx m a
-> ClientStTxIds blocking txid tx m a
wrapTxIds (SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply ClientStIdle txid tx m a
k) = BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
forall (blocking :: StBlockingStyle) txid tx (m :: * -> *) a.
BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)
    wrapTxIds (SendMsgDone a
a)             = a -> ClientStTxIds 'StBlocking txid tx m a
forall a txid tx (m :: * -> *).
a -> ClientStTxIds 'StBlocking txid tx m a
SendMsgDone a
a

    rollKeep :: STM m Bool
rollKeep = StrictTVar m StdGen -> (StdGen -> (Bool, StdGen)) -> STM m Bool
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m StdGen
genVar ((StdGen -> (Bool, StdGen)) -> STM m Bool)
-> (StdGen -> (Bool, StdGen)) -> STM m Bool
forall a b. (a -> b) -> a -> b
$ \StdGen
g ->
      case (Double, Double) -> StdGen -> (Double, StdGen)
forall a g. (UniformRange a, RandomGen g) => (a, a) -> g -> (a, g)
uniformR (Double
0 :: Double, Double
1) StdGen
g of
        (Double
x, StdGen
g') -> (Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
p, StdGen
g')


-- | Pad each non-empty 'MsgReplyTxIds' reply so the total length is at
-- least @req + n@, where @req@ is the count the inbound asked for.
-- Padding entries are duplicates of the first reply entry. Replies that
-- are already empty pass through unchanged.
--
-- Triggers 'ProtocolErrorTxIdsNotRequested' on the inbound side as soon
-- as @n > 0@.
extraTxIds
  :: forall txid tx m a.
     Monad m
  => Word16
  -> TxSubmissionClient txid tx m a
  -> TxSubmissionClient txid tx m a
extraTxIds :: forall txid tx (m :: * -> *) a.
Monad m =>
Word16
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
extraTxIds Word16
n (TxSubmissionClient m (ClientStIdle txid tx m a)
mIdle) =
    m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
TxSubmissionClient (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle (ClientStIdle txid tx m a -> ClientStIdle txid tx m a)
-> m (ClientStIdle txid tx m a) -> m (ClientStIdle txid tx m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle txid tx m a)
mIdle)
  where
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle { forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds, [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs } = ClientStIdle
      { recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds = \SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req -> do
          reply <- SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req
          pure (wrapTxIds req reply)
      , recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs   = \[txid]
txids -> do
          reply <- [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs [txid]
txids
          pure (wrapTxs reply)
      }

    wrapTxIds :: NumTxIdsToReq
              -> ClientStTxIds blocking txid tx m a
              -> ClientStTxIds blocking txid tx m a
    wrapTxIds :: forall (blocking :: StBlockingStyle).
NumTxIdsToReq
-> ClientStTxIds blocking txid tx m a
-> ClientStTxIds blocking txid tx m a
wrapTxIds NumTxIdsToReq
req (SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply ClientStIdle txid tx m a
k) = BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
forall (blocking :: StBlockingStyle) txid tx (m :: * -> *) a.
BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
SendMsgReplyTxIds (NumTxIdsToReq
-> BlockingReplyList blocking (txid, SizeInBytes)
-> BlockingReplyList blocking (txid, SizeInBytes)
forall (blocking :: StBlockingStyle).
NumTxIdsToReq
-> BlockingReplyList blocking (txid, SizeInBytes)
-> BlockingReplyList blocking (txid, SizeInBytes)
pad NumTxIdsToReq
req BlockingReplyList blocking (txid, SizeInBytes)
reply) (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)
    wrapTxIds NumTxIdsToReq
_   (SendMsgDone a
a)             = a -> ClientStTxIds 'StBlocking txid tx m a
forall a txid tx (m :: * -> *).
a -> ClientStTxIds 'StBlocking txid tx m a
SendMsgDone a
a

    wrapTxs :: ClientStTxs txid tx m a -> ClientStTxs txid tx m a
    wrapTxs :: ClientStTxs txid tx m a -> ClientStTxs txid tx m a
wrapTxs (SendMsgReplyTxs [tx]
txs ClientStIdle txid tx m a
k) = [tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
forall tx txid (m :: * -> *) a.
[tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
SendMsgReplyTxs [tx]
txs (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)

    -- Append (req + n - length xs) duplicates of the head, so the final
    -- length exceeds the requested count by exactly n.
    pad :: NumTxIdsToReq
        -> BlockingReplyList blocking (txid, SizeInBytes)
        -> BlockingReplyList blocking (txid, SizeInBytes)
    pad :: forall (blocking :: StBlockingStyle).
NumTxIdsToReq
-> BlockingReplyList blocking (txid, SizeInBytes)
-> BlockingReplyList blocking (txid, SizeInBytes)
pad NumTxIdsToReq
_   BlockingReplyList blocking (txid, SizeInBytes)
r | Word16
n Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 = BlockingReplyList blocking (txid, SizeInBytes)
r
    pad NumTxIdsToReq
req (BlockingReply NonEmpty (txid, SizeInBytes)
xs) =
        let target :: Int
target = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NumTxIdsToReq -> Word16
getNumTxIdsToReq NumTxIdsToReq
req) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n :: Int
            need :: Int
need   = Int
target Int -> Int -> Int
forall a. Num a => a -> a -> a
- NonEmpty (txid, SizeInBytes) -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty (txid, SizeInBytes)
xs
        in NonEmpty (txid, SizeInBytes)
-> BlockingReplyList 'StBlocking (txid, SizeInBytes)
forall a. NonEmpty a -> BlockingReplyList 'StBlocking a
BlockingReply (NonEmpty (txid, SizeInBytes)
xs NonEmpty (txid, SizeInBytes)
-> NonEmpty (txid, SizeInBytes) -> NonEmpty (txid, SizeInBytes)
forall a. Semigroup a => a -> a -> a
<> [(txid, SizeInBytes)] -> NonEmpty (txid, SizeInBytes)
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList
                                 (Int -> (txid, SizeInBytes) -> [(txid, SizeInBytes)]
forall a. Int -> a -> [a]
replicate Int
need (NonEmpty (txid, SizeInBytes) -> (txid, SizeInBytes)
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (txid, SizeInBytes)
xs)))
    pad NumTxIdsToReq
_   (NonBlockingReply []) = [(txid, SizeInBytes)]
-> BlockingReplyList 'StNonBlocking (txid, SizeInBytes)
forall a. [a] -> BlockingReplyList 'StNonBlocking a
NonBlockingReply []
    pad NumTxIdsToReq
req (NonBlockingReply xs :: [(txid, SizeInBytes)]
xs@((txid, SizeInBytes)
x:[(txid, SizeInBytes)]
_)) =
        let target :: Int
target = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NumTxIdsToReq -> Word16
getNumTxIdsToReq NumTxIdsToReq
req) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n :: Int
            need :: Int
need   = Int
target Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(txid, SizeInBytes)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(txid, SizeInBytes)]
xs
        in [(txid, SizeInBytes)]
-> BlockingReplyList 'StNonBlocking (txid, SizeInBytes)
forall a. [a] -> BlockingReplyList 'StNonBlocking a
NonBlockingReply ([(txid, SizeInBytes)]
xs [(txid, SizeInBytes)]
-> [(txid, SizeInBytes)] -> [(txid, SizeInBytes)]
forall a. [a] -> [a] -> [a]
++ Int -> (txid, SizeInBytes) -> [(txid, SizeInBytes)]
forall a. Int -> a -> [a]
replicate Int
need (txid, SizeInBytes)
x)


-- | Append a fabricated body to each non-empty 'MsgReplyTxs' whose txid
-- is not in the corresponding request list. Models a peer that replies
-- with bodies that were never asked for.
--
-- Triggers 'ProtocolErrorTxNotRequested' on the inbound side. The
-- fabricated body is produced by @mkBad reqs orig@ where @orig@ is the
-- first legitimate body in the reply (used as a template).
unrequestedTx
  :: forall txid tx m a.
     Monad m
  => ([txid] -> tx -> tx)
  -> TxSubmissionClient txid tx m a
  -> TxSubmissionClient txid tx m a
unrequestedTx :: forall txid tx (m :: * -> *) a.
Monad m =>
([txid] -> tx -> tx)
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
unrequestedTx [txid] -> tx -> tx
mkBad (TxSubmissionClient m (ClientStIdle txid tx m a)
mIdle) =
    m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
m (ClientStIdle txid tx m a) -> TxSubmissionClient txid tx m a
TxSubmissionClient (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle (ClientStIdle txid tx m a -> ClientStIdle txid tx m a)
-> m (ClientStIdle txid tx m a) -> m (ClientStIdle txid tx m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle txid tx m a)
mIdle)
  where
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
    wrapIdle :: ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle { forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds, [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs } = ClientStIdle
      { recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds = \SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req -> do
          reply <- SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ack NumTxIdsToReq
req
          pure (wrapTxIds reply)
      , recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs   = \[txid]
txids -> do
          reply <- [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs [txid]
txids
          pure (wrapTxs txids reply)
      }

    wrapTxIds :: ClientStTxIds blocking txid tx m a
              -> ClientStTxIds blocking txid tx m a
    wrapTxIds :: forall (blocking :: StBlockingStyle).
ClientStTxIds blocking txid tx m a
-> ClientStTxIds blocking txid tx m a
wrapTxIds (SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply ClientStIdle txid tx m a
k) = BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
forall (blocking :: StBlockingStyle) txid tx (m :: * -> *) a.
BlockingReplyList blocking (txid, SizeInBytes)
-> ClientStIdle txid tx m a -> ClientStTxIds blocking txid tx m a
SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
reply (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)
    wrapTxIds (SendMsgDone a
a)             = a -> ClientStTxIds 'StBlocking txid tx m a
forall a txid tx (m :: * -> *).
a -> ClientStTxIds 'StBlocking txid tx m a
SendMsgDone a
a

    wrapTxs :: [txid] -> ClientStTxs txid tx m a -> ClientStTxs txid tx m a
    wrapTxs :: [txid] -> ClientStTxs txid tx m a -> ClientStTxs txid tx m a
wrapTxs [txid]
_     (SendMsgReplyTxs []          ClientStIdle txid tx m a
k) = [tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
forall tx txid (m :: * -> *) a.
[tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
SendMsgReplyTxs [] (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)
    wrapTxs [txid]
txids (SendMsgReplyTxs txs :: [tx]
txs@(tx
x : [tx]
_) ClientStIdle txid tx m a
k) =
        [tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
forall tx txid (m :: * -> *) a.
[tx] -> ClientStIdle txid tx m a -> ClientStTxs txid tx m a
SendMsgReplyTxs ([tx]
txs [tx] -> [tx] -> [tx]
forall a. [a] -> [a] -> [a]
++ [[txid] -> tx -> tx
mkBad [txid]
txids tx
x]) (ClientStIdle txid tx m a -> ClientStIdle txid tx m a
wrapIdle ClientStIdle txid tx m a
k)


-- | Behavioural fault injection on a peer's outbound 'TxSubmissionClient'.
-- Peers configured with 'noImpairment' run unwrapped.
data Impairment = Impairment
  { Impairment -> Maybe DiffTime
impairBodyDelay     :: Maybe DiffTime
    -- ^ added before each MsgReplyTxs; txid replies are unaffected
  , Impairment -> Double
impairOmitProb      :: Double
    -- ^ per-body Bernoulli drop probability, in [0, 1]
  , Impairment -> Int
impairSeed          :: Int
    -- ^ seed for the per-peer StdGen used by 'omitBodies'
  , Impairment -> Word16
impairExtraTxIds    :: Word16
    -- ^ pad each MsgReplyTxIds with this many duplicate entries; 0 = off
  , Impairment -> Bool
impairUnrequestedTx :: Bool
    -- ^ append one fabricated body whose txid is not in the request
  } deriving (Impairment -> Impairment -> Bool
(Impairment -> Impairment -> Bool)
-> (Impairment -> Impairment -> Bool) -> Eq Impairment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Impairment -> Impairment -> Bool
== :: Impairment -> Impairment -> Bool
$c/= :: Impairment -> Impairment -> Bool
/= :: Impairment -> Impairment -> Bool
Eq, Int -> Impairment -> ShowS
[Impairment] -> ShowS
Impairment -> String
(Int -> Impairment -> ShowS)
-> (Impairment -> String)
-> ([Impairment] -> ShowS)
-> Show Impairment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Impairment -> ShowS
showsPrec :: Int -> Impairment -> ShowS
$cshow :: Impairment -> String
show :: Impairment -> String
$cshowList :: [Impairment] -> ShowS
showList :: [Impairment] -> ShowS
Show)

-- | The neutral impairment: no delay, no omission. Equivalent to running the
-- client unwrapped.
noImpairment :: Impairment
noImpairment :: Impairment
noImpairment = Impairment { impairBodyDelay :: Maybe DiffTime
impairBodyDelay     = Maybe DiffTime
forall a. Maybe a
Nothing
                          , impairOmitProb :: Double
impairOmitProb      = Double
0
                          , impairSeed :: Int
impairSeed          = Int
0
                          , impairExtraTxIds :: Word16
impairExtraTxIds    = Word16
0
                          , impairUnrequestedTx :: Bool
impairUnrequestedTx = Bool
False
                          }

-- | The invariants the 'Arbitrary' generator and 'shrinkImpairment' must
-- preserve: the omission probability is in [0, 1] and any body delay is
-- strictly positive. The seed, the duplicate count ('impairExtraTxIds' is
-- a 'Word16', so always non-negative) and the unrequested-tx flag are
-- unconstrained.
validImpairment :: Impairment -> Bool
validImpairment :: Impairment -> Bool
validImpairment Impairment
imp =
     Impairment -> Double
impairOmitProb Impairment
imp Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0
  Bool -> Bool -> Bool
&& Impairment -> Double
impairOmitProb Impairment
imp Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1
  Bool -> Bool -> Bool
&& Bool -> (DiffTime -> Bool) -> Maybe DiffTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
0) (Impairment -> Maybe DiffTime
impairBodyDelay Impairment
imp)

-- | Wrap a 'TxSubmissionClient' with the given 'Impairment'. Allocates a
-- per-peer 'StdGen' TVar only when the omission rate is non-zero. The
-- @mkBad@ argument is consulted only when 'impairUnrequestedTx' is set;
-- it produces a body whose txid is not in the request list.
applyImpairment :: (MonadDelay m, MonadSTM m)
                => Impairment
                -> ([txid] -> tx -> tx)
                -> TxSubmissionClient txid tx m a
                -> m (TxSubmissionClient txid tx m a)
applyImpairment :: forall (m :: * -> *) txid tx a.
(MonadDelay m, MonadSTM m) =>
Impairment
-> ([txid] -> tx -> tx)
-> TxSubmissionClient txid tx m a
-> m (TxSubmissionClient txid tx m a)
applyImpairment Impairment { Maybe DiffTime
impairBodyDelay :: Impairment -> Maybe DiffTime
impairBodyDelay :: Maybe DiffTime
impairBodyDelay, Double
impairOmitProb :: Impairment -> Double
impairOmitProb :: Double
impairOmitProb, Int
impairSeed :: Impairment -> Int
impairSeed :: Int
impairSeed
                           , Word16
impairExtraTxIds :: Impairment -> Word16
impairExtraTxIds :: Word16
impairExtraTxIds, Bool
impairUnrequestedTx :: Impairment -> Bool
impairUnrequestedTx :: Bool
impairUnrequestedTx } [txid] -> tx -> tx
mkBad TxSubmissionClient txid tx m a
c0 = do
    c1 <- if Double
impairOmitProb Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
            then do
              genVar <- StdGen -> m (StrictTVar m StdGen)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO (Int -> StdGen
mkStdGen Int
impairSeed)
              pure (omitBodies genVar impairOmitProb c0)
            else TxSubmissionClient txid tx m a
-> m (TxSubmissionClient txid tx m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxSubmissionClient txid tx m a
c0
    let c2 = case Maybe DiffTime
impairBodyDelay of
          Just DiffTime
d  -> DiffTime
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
MonadDelay m =>
DiffTime
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
delayBodies DiffTime
d TxSubmissionClient txid tx m a
c1
          Maybe DiffTime
Nothing -> TxSubmissionClient txid tx m a
c1
        c3 | Word16
impairExtraTxIds Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0 = Word16
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
Monad m =>
Word16
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
extraTxIds Word16
impairExtraTxIds TxSubmissionClient txid tx m a
c2
           | Bool
otherwise            = TxSubmissionClient txid tx m a
c2
        c4 | Bool
impairUnrequestedTx = ([txid] -> tx -> tx)
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
forall txid tx (m :: * -> *) a.
Monad m =>
([txid] -> tx -> tx)
-> TxSubmissionClient txid tx m a -> TxSubmissionClient txid tx m a
unrequestedTx [txid] -> tx -> tx
mkBad TxSubmissionClient txid tx m a
c3
           | Bool
otherwise           = TxSubmissionClient txid tx m a
c3
    pure c4


-- | Generate a single 'Impairment': a mix of body delay, per-body
-- omission, txid overflow, or unrequested body injection.
genOneImpairment :: Gen Impairment
genOneImpairment :: Gen Impairment
genOneImpairment = [Gen Impairment] -> Gen Impairment
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Gen Impairment
genOmit, Gen Impairment
genDelay, Gen Impairment
genBoth, Gen Impairment
genExtraTxIds, Gen Impairment
genUnrequestedTx]
  where
    genOmit :: Gen Impairment
genOmit = do
      p    <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0.1 :: Double, Double
0.9)
      seed <- arbitrary
      pure noImpairment { impairOmitProb = p, impairSeed = seed }
    genDelay :: Gen Impairment
genDelay = do
      d <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0.1 :: Double, Double
2.0)
      pure noImpairment { impairBodyDelay = Just (realToFrac d) }
    genBoth :: Gen Impairment
genBoth = do
      p    <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0.1 :: Double, Double
0.9)
      seed <- arbitrary
      d    <- choose (0.1 :: Double, 2.0)
      pure noImpairment { impairBodyDelay = Just (realToFrac d)
                        , impairOmitProb  = p
                        , impairSeed      = seed
                        }
    genExtraTxIds :: Gen Impairment
genExtraTxIds = do
      n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
5 :: Int)
      pure noImpairment { impairExtraTxIds = fromIntegral n }
    genUnrequestedTx :: Gen Impairment
genUnrequestedTx = Impairment -> Gen Impairment
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Impairment
noImpairment { impairUnrequestedTx = True }

-- | Shrink an 'Impairment' towards 'noImpairment'.
shrinkImpairment :: Impairment -> [Impairment]
shrinkImpairment :: Impairment -> [Impairment]
shrinkImpairment Impairment
imp = [Impairment] -> [Impairment]
forall a. Eq a => [a] -> [a]
List.nub ([Impairment] -> [Impairment]) -> [Impairment] -> [Impairment]
forall a b. (a -> b) -> a -> b
$
     [ Impairment
imp { impairUnrequestedTx = False } | Impairment -> Bool
impairUnrequestedTx Impairment
imp ]
  [Impairment] -> [Impairment] -> [Impairment]
forall a. [a] -> [a] -> [a]
++ [ Impairment
imp { impairExtraTxIds = a }        | Word16
a <- Word16 -> [Word16]
forall a. Arbitrary a => a -> [a]
shrink (Impairment -> Word16
impairExtraTxIds Impairment
imp) ]
  [Impairment] -> [Impairment] -> [Impairment]
forall a. [a] -> [a] -> [a]
++ [ Impairment
imp { impairBodyDelay = Nothing }   | Maybe DiffTime -> Bool
forall a. Maybe a -> Bool
isJust (Impairment -> Maybe DiffTime
impairBodyDelay Impairment
imp) ]
  [Impairment] -> [Impairment] -> [Impairment]
forall a. [a] -> [a] -> [a]
++ [ Impairment
imp { impairOmitProb = 0 }          | Impairment -> Double
impairOmitProb Impairment
imp Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 ]
  [Impairment] -> [Impairment] -> [Impairment]
forall a. [a] -> [a] -> [a]
++ [ Impairment
imp { impairBodyDelay = Just (realToFrac d') }
     | Just DiffTime
d <- [Impairment -> Maybe DiffTime
impairBodyDelay Impairment
imp]
     , Double
d' <- Double -> [Double]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
d :: Double)
     , Double
d' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
     , Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d' DiffTime -> DiffTime -> Bool
forall a. Eq a => a -> a -> Bool
/= DiffTime
d
     ]
  [Impairment] -> [Impairment] -> [Impairment]
forall a. [a] -> [a] -> [a]
++ [ Impairment
imp { impairOmitProb = p' }
     | Impairment -> Double
impairOmitProb Impairment
imp Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
     , Double
p' <- Double -> [Double]
forall a. Arbitrary a => a -> [a]
shrink (Impairment -> Double
impairOmitProb Impairment
imp)
     , Double
p' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
     ]

-- | A short label classifying an 'Impairment', for test labelling.
kindOf :: Impairment -> String
kindOf :: Impairment -> String
kindOf Impairment { impairUnrequestedTx :: Impairment -> Bool
impairUnrequestedTx = Bool
True }                    = String
"unrequested-tx"
kindOf Impairment { impairExtraTxIds :: Impairment -> Word16
impairExtraTxIds = Word16
n }                | Word16
n Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0   = String
"extra-txids"
kindOf Impairment { impairBodyDelay :: Impairment -> Maybe DiffTime
impairBodyDelay = Just DiffTime
_,  impairOmitProb :: Impairment -> Double
impairOmitProb = Double
0 } = String
"delay-only"
kindOf Impairment { impairBodyDelay :: Impairment -> Maybe DiffTime
impairBodyDelay = Just DiffTime
_,  impairOmitProb :: Impairment -> Double
impairOmitProb = Double
_ } = String
"delay+omit"
kindOf Impairment { impairBodyDelay :: Impairment -> Maybe DiffTime
impairBodyDelay = Maybe DiffTime
Nothing, impairOmitProb :: Impairment -> Double
impairOmitProb = Double
_ } = String
"omit-only"