From fb7f5973e24b32c80a2a3e824958c686ea49c7c0 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Tue, 17 Aug 2021 11:28:13 +0000 Subject: [PATCH] Add property tests for function `availableUTxO`. --- .../Cardano/Wallet/Primitive/ModelSpec.hs | 110 ++++++++++++++++++ 1 file changed, 110 insertions(+) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs index 9fe1ec9b4db..0759b6908ab 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -34,6 +35,7 @@ import Cardano.Wallet.Primitive.Model , initWallet , totalBalance , totalUTxO + , unsafeInitWallet ) import Cardano.Wallet.Primitive.Slotting.Legacy ( flatSlot ) @@ -65,8 +67,12 @@ import Cardano.Wallet.Primitive.Types.Tx , txIns , txOutCoin ) +import Cardano.Wallet.Primitive.Types.Tx.Gen + ( genTxIn, shrinkTxIn ) import Cardano.Wallet.Primitive.Types.UTxO ( Dom (..), UTxO (..), balance, excluding, restrictedTo ) +import Cardano.Wallet.Primitive.Types.UTxO.Gen + ( genUTxO, shrinkUTxO ) import Control.DeepSeq ( NFData (..) ) import Control.Monad @@ -108,17 +114,23 @@ import Test.QuickCheck , Gen , Positive (..) , Property + , Testable , checkCoverage , choose , classify , counterexample , cover , elements + , forAllShrink , frequency , genericShrink + , liftArbitrary + , liftShrink + , liftShrink2 , listOf , oneof , property + , scale , shrinkList , vector , withMaxSuccess @@ -128,6 +140,7 @@ import Test.QuickCheck import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle import qualified Data.ByteString as BS +import qualified Data.Foldable as F import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -163,6 +176,14 @@ spec = do it "only counts rewards once." (property prop_countRewardsOnce) + parallel $ describe "Available UTxO" $ do + it "prop_availableUTxO_isSubmap" $ + property prop_availableUTxO_isSubmap + it "prop_availableUTxO_notMember" $ + property prop_availableUTxO_notMember + it "prop_availableUTxO_withoutKeys" $ + property prop_availableUTxO_withoutKeys + {------------------------------------------------------------------------------- Properties -------------------------------------------------------------------------------} @@ -288,6 +309,95 @@ prop_countRewardsOnce (WithPending wallet pending rewards) pretty' :: Buildable a => a -> String pretty' = T.unpack . pretty +-------------------------------------------------------------------------------- +-- Available UTxO properties +-------------------------------------------------------------------------------- + +-- | Represents all the inputs of a transaction. +-- +data TxInputs = TxInputs + { inputs + :: [TxIn] + , collateral + :: [TxIn] + } + deriving (Eq, Show) + +genTxInputs :: Gen TxInputs +genTxInputs = TxInputs + <$> liftArbitrary genTxIn + <*> liftArbitrary genTxIn + +shrinkTxInputs :: TxInputs -> [TxInputs] +shrinkTxInputs TxInputs {inputs, collateral} = uncurry TxInputs <$> + liftShrink2 + (shrinkList shrinkTxIn) + (shrinkList shrinkTxIn) + (inputs, collateral) + +txInputsToSet :: TxInputs -> Set TxIn +txInputsToSet TxInputs {inputs, collateral} = + Set.fromList $ inputs <> collateral + +prop_availableUTxO_isSubmap :: Property +prop_availableUTxO_isSubmap = + prop_availableUTxO $ \utxo _pendingTxInputs result -> + unUTxO result `Map.isSubmapOf` unUTxO utxo + +prop_availableUTxO_notMember :: Property +prop_availableUTxO_notMember = + prop_availableUTxO $ \_utxo pendingTxInputs result -> + all (`Map.notMember` unUTxO result) + (F.foldMap txInputsToSet pendingTxInputs) + +prop_availableUTxO_withoutKeys :: Property +prop_availableUTxO_withoutKeys = + prop_availableUTxO $ \utxo pendingTxInputs result -> + unUTxO utxo `Map.withoutKeys` F.foldMap txInputsToSet pendingTxInputs + === unUTxO result + +prop_availableUTxO + :: Testable prop + => (UTxO -> [TxInputs] -> UTxO -> prop) + -> Property +prop_availableUTxO makeProperty = + forAllShrink (scale (* 4) genUTxO) shrinkUTxO + $ \utxo -> + forAllShrink (liftArbitrary genTxInputs) (liftShrink shrinkTxInputs) + $ \pendingTxInputs -> + inner utxo pendingTxInputs + where + inner utxo pendingTxInputs = + cover 5 (result /= mempty && result == utxo) + "result /= mempty && result == utxo" $ + cover 5 (result /= mempty && result /= utxo) + "result /= mempty && result /= utxo" $ + property $ makeProperty utxo pendingTxInputs result + where + result = availableUTxO + (Set.fromList $ txFromTxInputs <$> pendingTxInputs) + (walletFromUTxO utxo) + + txFromTxInputs :: TxInputs -> Tx + txFromTxInputs TxInputs {collateral, inputs} = Tx + { resolvedCollateral = (, Coin 0) <$> collateral + , resolvedInputs = (, Coin 0) <$> inputs + , txId = Hash "" + , fee = Nothing + , outputs = [] + , withdrawals = Map.empty + , metadata = Nothing + } + + walletFromUTxO :: UTxO -> Wallet s + walletFromUTxO utxo = unsafeInitWallet utxo + (shouldNotEvaluate "currentTip") + (shouldNotEvaluate "addressDiscoveryState") + where + shouldNotEvaluate :: String -> a + shouldNotEvaluate fieldName = error $ unwords + [fieldName, "was unexpectedly evaluated"] + {------------------------------------------------------------------------------- Basic Model - See Wallet Specification, section 3