Add test for throttling part of runLocalTxSubmissionPool

lib/core/cardano-wallet-core.cabal

@@ -308,6 +308,7 @@ test-suite unit
     , transformers
     , tree-diff
     , unliftio
+    , unliftio-core
     , unordered-containers
     , x509
     , x509-store

lib/core/src/Cardano/Wallet.hs

@@ -161,6 +161,9 @@ module Cardano.Wallet
     , ErrReadAccountPublicKey(..)
     , ErrInvalidDerivationIndex(..)
 
+    -- * Utilities
+    , throttle
+
     -- * Logging
     , WalletLog (..)
     , TxSubmitLog (..)
@@ -349,7 +352,7 @@ import Control.DeepSeq
 import Control.Monad
     ( forM, forM_, forever, replicateM, unless, when )
 import Control.Monad.Class.MonadTime
-    ( DiffTime, MonadMonotonicTime (..), diffTime, getCurrentTime )
+    ( DiffTime, MonadMonotonicTime (..), Time, diffTime, getCurrentTime )
 import Control.Monad.IO.Unlift
     ( MonadUnliftIO, liftIO )
 import Control.Monad.Trans.Class
@@ -1684,20 +1687,20 @@ runLocalTxSubmissionPool ctx wid = db & \DBLayer{..} -> forever $ do
     isScheduled sp now = (<= now) . scheduleLocalTxSubmission sp
 
     -- Limit pool check frequency to every 1000ms at most.
-    rateLimited = throttle 1
+    rateLimited = throttle 1 . const
 
 -- | Return a function to run an action at most once every _interval_.
 throttle
     :: (MonadUnliftIO m, MonadMonotonicTime m)
     => DiffTime
-    -> (a -> m ())
+    -> (Time -> a -> m ())
     -> m (a -> m ())
 throttle interval action = do
     var <- newMVar Nothing
     pure $ \arg -> modifyMVar_ var $ \prev -> do
         now <- getMonotonicTime
         if (maybe interval (diffTime now) prev >= interval)
-           then action arg $> Just now
+           then action now arg $> Just now
            else pure prev
 
 -- | List all transactions and metadata from history for a given wallet.

lib/core/test/unit/Cardano/WalletSpec.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -32,6 +33,7 @@ import Cardano.Wallet
     , ErrUpdatePassphrase (..)
     , ErrWithRootKey (..)
     , WalletLayer (..)
+    , throttle
     )
 import Cardano.Wallet.DB
     ( DBLayer (..), ErrNoSuchWallet (..), PrimaryKey (..), putTxHistory )
@@ -104,7 +106,6 @@ import Cardano.Wallet.Primitive.Types.Tx
     , TxMetadata
     , TxOut (..)
     , TxStatus (..)
-    , txId
     , txOutCoin
     )
 import Cardano.Wallet.Primitive.Types.UTxO
@@ -119,12 +120,18 @@ import Control.DeepSeq
     ( NFData (..) )
 import Control.Monad
     ( forM, forM_, replicateM, void )
-import Control.Monad.IO.Class
-    ( liftIO )
+import Control.Monad.Class.MonadTime
+    ( DiffTime, MonadMonotonicTime (..), Time (..), addTime, diffTime )
+import Control.Monad.IO.Unlift
+    ( MonadIO (..), MonadUnliftIO (..) )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT, except, runExceptT )
+import Control.Monad.Trans.Maybe
+    ( MaybeT (..) )
+import Control.Monad.Trans.State
+    ( StateT (..), state )
 import Control.Monad.Trans.State.Strict
     ( State, evalState, get, put )
 import Crypto.Hash
@@ -168,6 +175,8 @@ import Test.QuickCheck
     , Property
     , arbitraryBoundedEnum
     , arbitrarySizedBoundedIntegral
+    , arbitrarySizedFractional
+    , checkCoverage
     , checkCoverage
     , choose
     , conjoin
@@ -176,10 +185,12 @@ import Test.QuickCheck
     , elements
     , label
     , liftArbitrary
+    , listOf1
     , oneof
     , property
     , scale
     , shrinkIntegral
+    , suchThat
     , vector
     , withMaxSuccess
     , (===)
@@ -188,11 +199,11 @@ import Test.QuickCheck
 import Test.QuickCheck.Arbitrary.Generic
     ( genericArbitrary, genericShrink )
 import Test.QuickCheck.Monadic
-    ( monadicIO )
+    ( assert, monadicIO, monitor, run )
 import Test.Utils.Time
     ( UniformTime )
 import UnliftIO.Concurrent
-    ( threadDelay )
+    ( newEmptyMVar, putMVar, takeMVar, threadDelay )
 
 import qualified Cardano.Crypto.Wallet as CC
 import qualified Cardano.Wallet as W
@@ -210,7 +221,7 @@ import qualified Data.Set as Set
 
 spec :: Spec
 spec = parallel $ do
-    parallel $ describe "Pointless tests to cover 'Show' instances for errors" $ do
+    parallel $ describe "Pointless mockEventSource to cover 'Show' instances for errors" $ do
         let wid = WalletId (hash @ByteString "arbitrary")
         it (show $ ErrSignPaymentNoSuchWallet (ErrNoSuchWallet wid)) True
         it (show $ ErrSubmitTxNoSuchWallet (ErrNoSuchWallet wid)) True
@@ -251,13 +262,17 @@ spec = parallel $ do
         it "Fee estimates are sound"
             (property prop_estimateFee)
 
+    describe "LocalTxSubmission" $ do
+        it "LocalTxSubmission updates are limited in frequency"
+            (property prop_throttle)
+
     parallel $ describe "Join/Quit Stake pool properties" $ do
         it "You can quit if you cannot join"
             (property prop_guardJoinQuit)
         it "You can join if you cannot quit"
             (property prop_guardQuitJoin)
 
-    parallel $ describe "Join/Quit Stake pool unit tests" $ do
+    parallel $ describe "Join/Quit Stake pool unit mockEventSource" $ do
         let noRetirementPlanned = Nothing
         it "Cannot join A, when active = A" $ do
             let dlg = WalletDelegation {active = Delegating pidA, next = []}
@@ -377,10 +392,10 @@ prop_guardQuitJoin (NonEmpty knownPoolsList) dlg rewards =
 walletCreationProp
     :: (WalletId, WalletName, DummyState)
     -> Property
-walletCreationProp newWallet = monadicIO $ liftIO $ do
-    (WalletLayerFixture DBLayer{..} _wl walletIds _) <- setupFixture newWallet
-    resFromDb <- atomically $ readCheckpoint (PrimaryKey $ L.head walletIds)
-    resFromDb `shouldSatisfy` isJust
+walletCreationProp newWallet = monadicIO $ do
+    WalletLayerFixture DBLayer{..} _wl walletIds _ <- run $ setupFixture newWallet
+    resFromDb <- run $ atomically $ readCheckpoint (PrimaryKey $ L.head walletIds)
+    assert (isJust resFromDb)
 
 walletDoubleCreationProp
     :: (WalletId, WalletName, DummyState)
@@ -570,8 +585,9 @@ walletListTransactionsSorted wallet@(wid, _, _) _order (_mstart, _mend) history
         txs `shouldBe` L.sortOn (Down . slotNo . txInfoMeta) txs
         -- Check transaction time calculation
         let times = Map.fromList [(txInfoId i, txInfoTime i) | i <- txs]
-        let expTimes = Map.fromList $
-                (\(tx, meta) -> (txId tx, slotNoTime (meta ^. #slotNo))) <$> history
+        let expTimes = Map.fromList
+                [ (tx ^. #txId, slotNoTime (meta ^. #slotNo))
+                | (tx, meta) <- history ]
         times `shouldBe` expTimes
 
 {-------------------------------------------------------------------------------
@@ -628,6 +644,138 @@ prop_estimateFee (NonEmpty coins) =
         counterexample (show a <> " & " <> show b <> " are not close enough") $
         property $ abs (a - b) < (1/5)
 
+
+{-------------------------------------------------------------------------------
+                               LocalTxSubmission
+-------------------------------------------------------------------------------}
+
+data ThrottleTest = ThrottleTest
+    { interval :: DiffTime
+    , diffTimes :: [DiffTime]
+    } deriving (Generic, Show, Eq)
+
+instance Arbitrary ThrottleTest where
+    arbitrary = ThrottleTest <$> genInterval <*> listOf1 genDiffTime
+      where
+        genInterval = genDiffTime `suchThat` (> 0)
+        genDiffTime = abs <$> arbitrarySizedFractional
+    shrink (ThrottleTest i dts) =
+        [ ThrottleTest (fromRational i') (map fromRational dts')
+        | (i', dts') <- shrink (toRational i, map toRational dts)
+        , i' > 0, not (null dts') ]
+
+data ThrottleTestState = ThrottleTestState
+    { remainingDiffTimes :: [DiffTime]
+    , now :: Time
+    , actions :: [(Time, Int)]
+    } deriving (Generic, Show, Eq)
+
+newtype ThrottleTestT m a = ThrottleTestT
+    { unThrottleTestT :: MaybeT (StateT ThrottleTestState m) a
+    } deriving (Functor, Applicative, Monad, MonadIO)
+
+runThrottleTest
+    :: MonadIO m
+    => ThrottleTestT m a
+    -> ThrottleTestState
+    -> m (Maybe a, ThrottleTestState)
+runThrottleTest action = fmap r . runStateT (runMaybeT (unThrottleTestT action))
+  where
+    r (res, ThrottleTestState d n a) = (res, ThrottleTestState d n (reverse a))
+
+initState :: ThrottleTest -> ThrottleTestState
+initState (ThrottleTest _ dts) = ThrottleTestState dts (Time 0) []
+
+recordTime :: Monad m => Time -> Int -> ThrottleTestT m ()
+recordTime now i = ThrottleTestT $ lift $ state $
+    \(ThrottleTestState ts now as) ->
+    ((), ThrottleTestState ts now ((now, i):as))
+
+instance MonadMonotonicTime m => MonadMonotonicTime (ThrottleTestT m) where
+    getMonotonicTime = ThrottleTestT $ MaybeT $ state mockTime
+      where
+        mockTime (ThrottleTestState ts now as) = case ts of
+            [] -> (Nothing, ThrottleTestState ts now as)
+            (t:ts) ->
+                let now' = addTime t now
+                in  (Just now', ThrottleTestState ts now' as)
+
+instance MonadUnliftIO m => MonadUnliftIO (StateT ThrottleTestState m) where
+  withRunInIO inner = StateT $ \tts -> do
+      -- smuggle the test state in an mvar
+      var <- newEmptyMVar
+      withRunInIO $ \run -> do
+          a <- inner $ \action -> do
+              (a, tts') <- run $ runStateT action tts
+              putMVar var tts'
+              pure a
+          tts' <- takeMVar var
+          pure (a, tts')
+
+instance MonadUnliftIO m => MonadUnliftIO (ThrottleTestT m) where
+    withRunInIO inner = ThrottleTestT $ MaybeT $ fmap Just $
+        withRunInIO $ \run -> inner $ \(ThrottleTestT action) ->
+            run (runMaybeT action) >>= maybe (error "bad test") pure
+
+-- | 'throttle' ensures than the action runs when called to, at most once per
+-- interval.
+prop_throttle :: ThrottleTest -> Property
+prop_throttle tc@(ThrottleTest interval diffTimes) = monadicIO $ do
+    (res, st) <- run $ runThrottleTest testAction (initState tc)
+    -- check test case
+    monitor coverageTests
+    -- info for debugging failed mockEventSource
+    monitor $ counterexample $ unlines
+        [ ("res      = " ++ show res)
+        , ("st       = " ++ show st)
+        , ("accTimes = " ++ show accTimes)
+        , ("actuals  = " ++ show (actions st))
+        , ("expected = " ++ show expected)
+        ]
+    -- sanity-check test runner
+    assertNamed "consumed test data" (null $ remainingDiffTimes st)
+    assertNamed "expected final time" (now st == finalTime)
+    assertNamed "runner success" (isJust res)
+    -- properties
+    assertNamed "action runs at most once per interval" $
+        all (<= interval) (timeDeltas (map fst (actions st)))
+    assertNamed "action runs whenever interval has passed" $
+        length diffTimes <= 1 || actions st == expected
+  where
+    testAction :: ThrottleTestT IO ()
+    testAction = do
+        rateLimited <- throttle interval recordTime
+        mockEventSource rateLimited 0
+
+    mockEventSource cb n
+         | n < length diffTimes = cb n >> mockEventSource cb (n + 1)
+         | otherwise = pure ()
+
+    finalTime = addTime (sum diffTimes) (Time 0)
+    accTimes = drop 1 $ L.scanl' (flip addTime) (Time 0) diffTimes
+
+    expected = reverse $ snd $ L.foldl' model (Time (negate interval), []) $
+        zip accTimes [0..]
+
+    model (prev, xs) (now, i)
+        | diffTime now prev >= interval = (now, (now, i):xs)
+        | otherwise = (prev, xs)
+
+    timeDeltas xs = zipWith diffTime (drop 1 xs) xs
+
+    assertNamed label prop = do
+        monitor $ counterexample $ label ++ ": " ++ show prop
+        assert prop
+
+    coverageTests = checkCoverage
+        . cover 1 (interval < 1) "sub-second interval"
+        . cover 25 (interval >= 1) "super-second interval"
+        . cover 25 (length diffTimes >= 10) "long mockEventSource"
+        . cover 25 (testRatio >= 0.5 && testRatio <= 1.5) "reasonable interval"
+      where
+        avgDiffTime = sum diffTimes / fromIntegral (length diffTimes)
+        testRatio = avgDiffTime / interval
+
 {-------------------------------------------------------------------------------
                       Tests machinery, Arbitrary instances
 -------------------------------------------------------------------------------}
@@ -699,7 +847,7 @@ dummyTransactionLayer = TransactionLayer
         wit <- forM (inputsSelected cs) $ \(_, TxOut addr _) -> do
             (xprv, Passphrase pwd) <- withEither
                 (ErrKeyNotFoundForAddress addr) $ keystore addr
-            let (Hash sigData) = txId tx
+            let sigData = tx ^. #txId . #getHash
             let sig = CC.unXSignature $ CC.sign pwd (getKey xprv) sigData
             return $ xpubToBytes (getKey $ publicKey xprv) <> sig