Skip to content

Commit

Permalink
Remove LocalTxSubmission use from WalletSpec
Browse files Browse the repository at this point in the history
  • Loading branch information
@paolino
paolino committed Feb 8, 2023
1 parent 5f03ea5 commit bb2f7ed
Show file tree
Hide file tree
Showing 2 changed files with 48 additions and 98 deletions.
11 changes: 6 additions & 5 deletions lib/wallet/src/Cardano/Wallet.hs
View file
Expand Up @@ -2300,13 +2300,14 @@ mkTxMeta latestBlockHeader txValidity amountIn amountOut =
}

-- | Broadcast a (signed) transaction to the network.
submitTx
:: Tracer IO WalletWorkerLog
-> DBLayer IO s k
-> NetworkLayer IO Read.Block

submitTx :: MonadUnliftIO m =>
Tracer m WalletWorkerLog
-> DBLayer m s k
-> NetworkLayer m block
-> WalletId
-> BuiltTx
-> ExceptT ErrSubmitTx IO ()
-> ExceptT ErrSubmitTx m ()
submitTx tr DBLayer{..} nw walletId tx@BuiltTx{..} =
traceResult (MsgWallet . MsgTxSubmit . MsgSubmitTx tx >$< tr) $ do
withExceptT ErrSubmitTxNetwork $ postTx nw builtSealedTx
Expand Down
135 changes: 42 additions & 93 deletions lib/wallet/test/unit/Cardano/WalletSpec.hs
View file
Expand Up @@ -15,6 +15,8 @@
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.WalletSpec
( spec
Expand Down Expand Up @@ -43,6 +45,7 @@ import Cardano.Wallet
, WalletLayer (..)
, migrationPlanToSelectionWithdrawals
, runLocalTxSubmissionPool
, submitTx
, throttle
)
import Cardano.Wallet.DB
Expand All @@ -58,7 +61,7 @@ import Cardano.Wallet.DummyTarget.Primitive.Types
, mkTxId
)
import Cardano.Wallet.Gen
( genMnemonic, genSlotNo, shrinkSlotNo )
( genMnemonic, genSlotNo )
import Cardano.Wallet.Network
( NetworkLayer (..) )
import Cardano.Wallet.Primitive.AddressDerivation
Expand Down Expand Up @@ -116,13 +119,11 @@ import Cardano.Wallet.Primitive.Types.TokenQuantity.Gen
( genTokenQuantityPositive )
import Cardano.Wallet.Primitive.Types.Tx
( Direction (..)
, LocalTxSubmissionStatus (..)
, SealedTx (..)
, TransactionInfo (..)
, Tx (..)
, TxMeta (..)
, TxStatus (..)
, isPending
, mockSealedTx
)
import Cardano.Wallet.Primitive.Types.Tx.Constraints
Expand All @@ -149,6 +150,8 @@ import Cardano.Wallet.Util
( HasCallStack )
import Control.DeepSeq
( NFData (..) )
import Control.Lens
( _2 )
import Control.Monad
( forM_, replicateM, void )
import Control.Monad.Class.MonadTime
Expand All @@ -172,7 +175,7 @@ import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict
( State, StateT (..), evalState, get, put, state )
import Control.Tracer
( Tracer (..), nullTracer )
( Tracer (..), natTracer, nullTracer )
import Crypto.Hash
( hash )
import Data.Bifunctor
Expand All @@ -183,10 +186,8 @@ import Data.Coerce
( coerce )
import Data.Either
( isLeft, isRight )
import Data.Function
( on )
import Data.Generics.Internal.VL
( iso, set, view, (^.) )
( iso, view, (^.) )
import Data.List.NonEmpty
( NonEmpty (..) )
import Data.Map.Strict
Expand Down Expand Up @@ -230,13 +231,10 @@ import Test.QuickCheck
, forAllBlind
, label
, liftArbitrary
, liftShrink
, liftShrink2
, listOf1
, oneof
, property
, scale
, shrinkList
, sized
, suchThat
, vector
Expand Down Expand Up @@ -644,8 +642,7 @@ prop_estimateFee (NonEmpty coins) =
-------------------------------------------------------------------------------}

data TxRetryTest = TxRetryTest
{ retryTestPool :: [LocalTxSubmissionStatus SealedTx]
, retryTestTxHistory :: GenTxHistory
{ retryTestPool :: [(TxMeta, SealedTx)]
, postTxResults :: [(SealedTx, Bool)]
, testSlottingParameters :: SlottingParameters
, retryTestWallet :: (WalletId, WalletName, DummyState)
Expand All @@ -654,74 +651,37 @@ data TxRetryTest = TxRetryTest
numSlots :: TxRetryTest -> Word64
numSlots = const 100

newtype GenTxHistory = GenTxHistory { getTxHistory :: [(Tx, TxMeta)] }
type TxCore = (Hash "Tx", TxMeta)
newtype GenSubmissions = GenSubmissions { genSubmissions :: [TxCore] }
deriving (Generic, Show, Eq)

instance Arbitrary GenTxHistory where
arbitrary = fmap GenTxHistory (gen `suchThat` hasPending)
instance Arbitrary GenSubmissions where
arbitrary = fmap GenSubmissions $ listOf1 genTxMeta
where
gen = uniq <$> listOf1 ((,) <$> genTx' <*> genTxMeta)
uniq = L.nubBy ((==) `on` (view #txId . fst))
genTx' = mkTx <$> genTid
hasPending = any ((== Pending) . view #status . snd)
genTid = Hash . B8.pack <$> listOf1 (elements ['A'..'Z'])
mkTx txId = Tx
{ txId
, txCBOR = Nothing
, fee = Nothing
, resolvedInputs = []
, resolvedCollateralInputs = []
, outputs = []
, collateralOutput = Nothing
, withdrawals = mempty
, metadata = Nothing
, scriptValidity = Nothing
}
genTxMeta = do
sl <- genSmallSlot
let bh = Quantity $ fromIntegral $ unSlotNo sl
st <- elements [Pending, InLedger, Expired]
dir <- elements [Incoming, Outgoing]
st <- elements [Pending]
dir <- elements [Outgoing]
expry <- oneof [fmap (Just . (+ sl)) genSmallSlot, pure Nothing]
pure $ TxMeta st dir sl bh (Coin 0) expry
i <- arbitrary
pure $ (i, TxMeta st dir sl bh (Coin 0) expry)
genSmallSlot = SlotNo . fromIntegral <$> sized (\n -> choose (0, 4 * n))

shrink = fmap GenTxHistory
. filter (not . null)
. shrinkList (liftShrink2 shrinkTx' shrinkMeta)
. getTxHistory
where
shrinkTx' tx = [set #txId tid' tx | tid' <- shrink (view #txId tx)]
shrinkMeta (TxMeta st dir sl bh amt ex) =
[ TxMeta st dir sl' bh amt ex'
| (sl', ex') <- liftShrink2 shrinkSlotNo (liftShrink shrinkSlotNo)
(sl, ex) ]

instance Arbitrary TxRetryTest where
arbitrary = do
txHistory <- arbitrary
let pool = mkLocalTxSubmissionStatus txHistory
results <- zip (map (view #submittedTx) pool) . getInfiniteList <$> arbitrary
TxRetryTest pool txHistory results <$> arbitrary <*> arbitrary

shrink (TxRetryTest _ txHistory res sp wal) =
[ TxRetryTest (mkLocalTxSubmissionStatus txHistory') txHistory' res sp' wal'
| (txHistory', sp', wal') <- shrink (txHistory, sp, wal)
]
metas <- arbitrary
let pool = mkLocalTxSubmissionStatus metas
results <- zip (map (view _2) pool) . getInfiniteList <$> arbitrary
TxRetryTest pool results <$> arbitrary <*> arbitrary

mkLocalTxSubmissionStatus
:: GenTxHistory
-> [LocalTxSubmissionStatus SealedTx]
mkLocalTxSubmissionStatus = mapMaybe getStatus . getTxHistory
:: GenSubmissions
-> [(TxMeta, SealedTx)]
mkLocalTxSubmissionStatus = fmap getStatus . genSubmissions
where
getStatus :: (Tx, TxMeta) -> Maybe (LocalTxSubmissionStatus SealedTx)
getStatus (tx, txMeta)
| isPending txMeta = Just st
| otherwise = Nothing
where
i = tx ^. #txId
sl = txMeta ^. #slotNo
st = LocalTxSubmissionStatus i (fakeSealedTx (tx, [])) sl
getStatus :: (Hash "Tx", TxMeta) -> (TxMeta, SealedTx)
getStatus (i,txMeta) = (txMeta, fakeSealedTx (i, []))

instance Arbitrary SlottingParameters where
arbitrary = mk <$> choose (0.5, 1)
Expand All @@ -733,9 +693,12 @@ instance Arbitrary SlottingParameters where
data TxRetryTestCtx = TxRetryTestCtx
{ ctxDbLayer :: DBLayer TxRetryTestM DummyState ShelleyKey
, ctxNetworkLayer :: NetworkLayer TxRetryTestM Read.Block
, ctxRetryTracer :: Tracer TxRetryTestM W.WalletWorkerLog
, ctxTracer :: Tracer IO W.WalletWorkerLog
, ctxWalletId :: WalletId
} deriving (Generic)
}

deriving instance Generic TxRetryTestCtx

-- | Context of 'TxRetryTestM'.
data TxRetryTestState = TxRetryTestState
Expand Down Expand Up @@ -772,14 +735,12 @@ instance MonadTime TxRetryTestM where
prop_localTxSubmission :: TxRetryTest -> Property
prop_localTxSubmission tc = monadicIO $ do
st <- TxRetryTestState tc 2 <$> newMVar (Time 0)
res <- run $ runTest st $ \ctx@(TxRetryTestCtx DBLayer{..} _ _ wid) -> do
-- Test setup
atomically $ do
let txHistory = getTxHistory (retryTestTxHistory tc)
unsafeRunExceptT $ putTxHistory wid txHistory
forM_ (retryTestPool tc) $ \(LocalTxSubmissionStatus i tx sl) ->
unsafeRunExceptT $ putLocalTxSubmission wid i tx sl

res <- run $ runTest st $ \ctx@(TxRetryTestCtx dbl@(DBLayer{..}) nl tr _ wid) -> do
unsafeRunExceptT
$ forM_ (retryTestPool tc) $ \(meta, sealed) -> do
submitTx tr dbl nl wid
$ W.BuiltTx undefined meta sealed
-- addTxSubmission wid (meta,sealed) sl
-- Run test
let cfg = LocalTxSubmissionConfig (timeStep st) 10
runLocalTxSubmissionPool @_ @DummyState @ShelleyKey cfg ctx wid
Expand All @@ -795,16 +756,9 @@ prop_localTxSubmission tc = monadicIO $ do

-- props:
-- 1. pending transactions in pool are retried
let inPool = (`elem` (submittedTx <$> retryTestPool tc))
let inPool x = x `elem` (view _2 <$> retryTestPool tc)
assert (all inPool (resSubmittedTxs res))

-- 2. non-pending transactions not retried
let nonPending = map (view #txId . fst)
. filter ((/= Pending) . view #status . snd)
. getTxHistory $ retryTestTxHistory tc
assert (all (`notElem` (map fakeSealedTxId $ resSubmittedTxs res)) nonPending)

-- 3. retries can fail and not break the wallet
assert (not $ null $ resAction res)

where
Expand All @@ -818,7 +772,8 @@ prop_localTxSubmission tc = monadicIO $ do
flip runReaderT st $ unTxRetryTestM $ do
WalletLayerFixture db _wl [wid] _slotNoTime <-
setupFixture $ retryTestWallet tc
let ctx = TxRetryTestCtx db (mockNetwork submittedVar) tr wid
let ctx = TxRetryTestCtx db (mockNetwork submittedVar)
(natTracer liftIO tr) tr wid

testAction ctx
TxRetryTestResult msgs res <$> readMVar submittedVar
Expand Down Expand Up @@ -1209,7 +1164,7 @@ dummyTransactionLayer = TransactionLayer
return $ xpubToBytes (getKey $ publicKey xprv) <> sig

-- (tx1, wit1) == (tx2, wit2) <==> fakebinary1 == fakebinary2
let fakeBinary = fakeSealedTx (tx, wit)
let fakeBinary = fakeSealedTx (tx ^. #txId, wit)
return (tx, fakeBinary)

, addVkWitnesses =
Expand Down Expand Up @@ -1263,16 +1218,10 @@ dummyTransactionLayer = TransactionLayer
forMaybe :: [a] -> (a -> Maybe b) -> [b]
forMaybe = flip mapMaybe

fakeSealedTx :: HasCallStack => (Tx, [ByteString]) -> SealedTx
fakeSealedTx :: HasCallStack => (Hash "Tx", [ByteString]) -> SealedTx
fakeSealedTx (tx, wit) = mockSealedTx $ B8.pack repr
where
repr = show (view #txId tx, wit)

fakeSealedTxId :: SealedTx -> Hash "Tx"
fakeSealedTxId = fst . parse . B8.unpack . serialisedTx
where
parse :: String -> (Hash "Tx", [ByteString])
parse = read
repr = show (tx, wit)

mockNetworkLayer :: Monad m => NetworkLayer m block
mockNetworkLayer = dummyNetworkLayer
Expand Down

0 comments on commit bb2f7ed

Please sign in to comment.