Add property tests for function availableUTxO.

cardano-foundation · Aug 18, 2021 · fb7f597 · fb7f597
1 parent b34251e
commit fb7f597
Showing 1 changed file with 110 additions and 0 deletions.
diff --git 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