{-# LANGUAGE NamedFieldPuns #-}

module Test.Ouroboros.Network.TxSubmission.Mempool.Simple (tests) where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadTime (MonadTime)
import Control.Monad.IOSim

import Data.Foldable qualified as Foldable
import Data.Function (on)
import Data.List (nub, nubBy)
import Data.Set qualified as Set
import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..),
           MempoolSeq (..))
import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool

import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Network.TxSubmission.Mempool.Simple"
        [ TestName -> (MempoolTxs -> [Tx] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"mempool writer" MempoolTxs -> [Tx] -> Property
prop_mempool_writer
        ]


-- | `Tx` is a tuple of `txid` and a bool representing validity of the tx
--
data Tx   = Tx { Tx -> TxId
getTxId    :: TxId,
                 Tx -> Bool
getTxValid :: Bool
               }
  deriving (TxId -> Tx -> ShowS
[Tx] -> ShowS
Tx -> TestName
(TxId -> Tx -> ShowS)
-> (Tx -> TestName) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(TxId -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: TxId -> Tx -> ShowS
showsPrec :: TxId -> Tx -> ShowS
$cshow :: Tx -> TestName
show :: Tx -> TestName
$cshowList :: [Tx] -> ShowS
showList :: [Tx] -> ShowS
Show, Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
/= :: Tx -> Tx -> Bool
Eq)
type TxId = Int

data ValidtionError = DuplicateTxId
                    | InvalidTx
  deriving TxId -> ValidtionError -> ShowS
[ValidtionError] -> ShowS
ValidtionError -> TestName
(TxId -> ValidtionError -> ShowS)
-> (ValidtionError -> TestName)
-> ([ValidtionError] -> ShowS)
-> Show ValidtionError
forall a.
(TxId -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: TxId -> ValidtionError -> ShowS
showsPrec :: TxId -> ValidtionError -> ShowS
$cshow :: ValidtionError -> TestName
show :: ValidtionError -> TestName
$cshowList :: [ValidtionError] -> ShowS
showList :: [ValidtionError] -> ShowS
Show


instance Arbitrary Tx where
  arbitrary :: Gen Tx
arbitrary = TxId -> Bool -> Tx
Tx (TxId -> Bool -> Tx) -> Gen TxId -> Gen (Bool -> Tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxId
forall a. Arbitrary a => Gen a
arbitrary
                 Gen (Bool -> Tx) -> Gen Bool -> Gen Tx
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: Tx -> [Tx]
shrink tx :: Tx
tx@Tx { TxId
getTxId :: Tx -> TxId
getTxId :: TxId
getTxId, Bool
getTxValid :: Tx -> Bool
getTxValid :: Bool
getTxValid } =
    [ Tx
tx { getTxId = getTxId' }
    | TxId
getTxId' <- TxId -> [TxId]
forall a. Arbitrary a => a -> [a]
shrink TxId
getTxId
    ]
    [Tx] -> [Tx] -> [Tx]
forall a. [a] -> [a] -> [a]
++
    [ Tx
tx { getTxValid = getTxValid' }
    | Bool
getTxValid' <- Bool -> [Bool]
forall a. Arbitrary a => a -> [a]
shrink Bool
getTxValid
    ]

-- | A list of valid tx's
newtype MempoolTxs = MempoolTxs [Tx]
  deriving TxId -> MempoolTxs -> ShowS
[MempoolTxs] -> ShowS
MempoolTxs -> TestName
(TxId -> MempoolTxs -> ShowS)
-> (MempoolTxs -> TestName)
-> ([MempoolTxs] -> ShowS)
-> Show MempoolTxs
forall a.
(TxId -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: TxId -> MempoolTxs -> ShowS
showsPrec :: TxId -> MempoolTxs -> ShowS
$cshow :: MempoolTxs -> TestName
show :: MempoolTxs -> TestName
$cshowList :: [MempoolTxs] -> ShowS
showList :: [MempoolTxs] -> ShowS
Show

instance Arbitrary MempoolTxs where
  arbitrary :: Gen MempoolTxs
arbitrary = do
    txids <- Gen [TxId]
forall a. Arbitrary a => Gen a
arbitrary
    return $ MempoolTxs [ Tx txid True | txid <- nub txids ]
  shrink :: MempoolTxs -> [MempoolTxs]
shrink (MempoolTxs [Tx]
txs) = [Tx] -> MempoolTxs
MempoolTxs ([Tx] -> MempoolTxs) -> [[Tx]] -> [MempoolTxs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tx -> [Tx]) -> [Tx] -> [[Tx]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Tx] -> Tx -> [Tx]
forall a b. a -> b -> a
const []) [Tx]
txs


prop_mempool_writer
  :: MempoolTxs
  -> [Tx]
  -> Property
prop_mempool_writer :: MempoolTxs -> [Tx] -> Property
prop_mempool_writer (MempoolTxs [Tx]
mempoolTxs) [Tx]
candidateTxs =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s Property
forall s. IOSim s Property
forall (m :: * -> *). (MonadSTM m, MonadTime m) => m Property
sim
  where
    candidateTxIdsSet :: Set TxId
candidateTxIdsSet = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList [ Tx -> TxId
getTxId Tx
tx | Tx
tx <- [Tx]
candidateTxs ]

    sim :: (MonadSTM m, MonadTime m)
        => m Property
    sim :: forall (m :: * -> *). (MonadSTM m, MonadTime m) => m Property
sim = do
      mempool@(Mempool mempoolVar) <- (Tx -> TxId) -> [Tx] -> m (Mempool m TxId Tx)
forall (m :: * -> *) txid tx.
(MonadSTM m, Ord txid) =>
(tx -> txid) -> [tx] -> m (Mempool m txid tx)
Mempool.new Tx -> TxId
getTxId [Tx]
mempoolTxs
      let writer = ValidtionError
-> (Tx -> TxId)
-> (UTCTime -> [Tx] -> STM m [Either (TxId, ValidtionError) Tx])
-> ([(TxId, ValidtionError)] -> m ())
-> Mempool m TxId Tx
-> TxSubmissionMempoolWriter TxId Tx Integer m ValidtionError
forall tx txid failure (m :: * -> *).
(MonadSTM m, MonadTime m, Ord txid) =>
failure
-> (tx -> txid)
-> (UTCTime -> [tx] -> STM m [Either (txid, failure) tx])
-> ([(txid, failure)] -> m ())
-> Mempool m txid tx
-> TxSubmissionMempoolWriter txid tx Integer m failure
Mempool.getWriter
                     ValidtionError
DuplicateTxId
                     Tx -> TxId
getTxId
                     (\UTCTime
_ [Tx]
txs -> [Either (TxId, ValidtionError) Tx]
-> STM m [Either (TxId, ValidtionError) Tx]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ case Tx
tx of
                                         Tx { getTxValid :: Tx -> Bool
getTxValid = Bool
False } -> (TxId, ValidtionError) -> Either (TxId, ValidtionError) Tx
forall a b. a -> Either a b
Left (Tx -> TxId
getTxId Tx
tx, ValidtionError
InvalidTx)
                                         Tx { getTxValid :: Tx -> Bool
getTxValid = Bool
True }  -> Tx -> Either (TxId, ValidtionError) Tx
forall a b. b -> Either a b
Right Tx
tx
                                     | Tx
tx <- [Tx]
txs
                                     ])
                     (\[(TxId, ValidtionError)]
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                     Mempool m TxId Tx
mempool
      (accepted, rejected) <- Mempool.mempoolAddTxs writer candidateTxs
      let acceptedSet = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList [TxId]
accepted
          rejectedSet = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList ((TxId, ValidtionError) -> TxId
forall a b. (a, b) -> a
fst ((TxId, ValidtionError) -> TxId)
-> [(TxId, ValidtionError)] -> [TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxId, ValidtionError)]
rejected)
      mempoolTxs' <- Mempool.read mempool
      MempoolSeq { mempoolSeq, nextIdx } <- readTVarIO mempoolVar
      let indices = WithIndex Tx -> Integer
forall tx. WithIndex tx -> Integer
Mempool.getIdx (WithIndex Tx -> Integer) -> [WithIndex Tx] -> [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (WithIndex Tx) -> [WithIndex Tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (WithIndex Tx)
mempoolSeq
      return . counterexample ("accepted " ++ show accepted)
             . counterexample ("rejected " ++ show rejected)
             . counterexample ("mempoolTxs' " ++ show mempoolTxs')

          --
          -- accepted & rejected properties
          --
             $ counterexample "acceptedSet not a subset of candidateTxIdsSet"
               (acceptedSet `Set.isSubsetOf` candidateTxIdsSet)
          .&&. counterexample "rejectedSet not a subset of candidateTxIdsSet"
               (rejectedSet `Set.isSubsetOf` candidateTxIdsSet)

               -- The first property guarantees that sets of accepted and
               -- rejected txids is equal to the candidate set; since we know
               -- from the two previous properties that no transaction was
               -- added, the second property below guarantees that every
               -- proposed transaction is either reported as accepted or
               -- rejected.
          .&&. counterexample "acceptedSet and rejectedSet does not sum up to the candidateTxIdsSet"
                              ((acceptedSet `Set.union` rejectedSet) === candidateTxIdsSet)
          .&&. counterexample "number of accepted and rejected txs is not equal to the number of candidate txs"
                              (length accepted + length rejected === length candidateTxs)
          --
          -- mempool properties
          --
          .&&. counterexample "all txs in the mempool are valid"
                              (all getTxValid mempoolTxs')
          .&&. counterexample "no duplicate txids in the mempool"
                              (nubBy (on (==) getTxId) mempoolTxs' === mempoolTxs')
          --
          -- mempool indices
          --
          .&&. counterexample "indices are distinct"
                              (indices === nub indices)
          .&&. counterexample "nextIdx is correct"
                              (if null mempoolSeq
                                 then nextIdx === 0
                                 else nextIdx === maximum indices + 1
                              )