Merge #2620

2620: Add `constraints` field to `TransactionLayer` r=rvl a=jonathanknowles # Issue Number ADP-839 # Overview This PR: - [x] adds field `constraints` of type `TxConstraints` to the `TransactionLayer` record type. - [x] adds an implementation of `constraints` to `Shelley.Transaction.TransactionLayer`. - [x] adds property tests to demonstrate the correctness of `Shelley.Transaction.TransactionLayer.constraints`. # Refactoring This PR also: - [x] makes `TxSize` into a concrete type exported by `Primitive.Types.Tx`. - [x] removes `calcMinimumCoinValue` from `TransactionLayer`, as `TxConstraints.txOutputMinimumAdaQuantity` makes this redundant. # Future work This PR will make it possible to: - remove `tokenBundleSizeAssessor` from `TransactionLayer`, as `TxConstraints.txOutputMaximumSize` makes this redundant. Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>
cardano-foundation · Apr 30, 2021 · 182e864 · 182e864
2 parents 5c414e2 + e687560
commit 182e864
Show file tree

Hide file tree

Showing 12 changed files with 666 additions and 272 deletions.
diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
@@ -1378,7 +1378,9 @@ calcMinimumCoinValues
     -> IO (f Coin)
 calcMinimumCoinValues ctx outs = do
     pp <- currentProtocolParameters nl
-    pure $ calcMinimumCoinValue tl pp . view (#tokens . #tokens) <$> outs
+    pure
+        $ view #txOutputMinimumAdaQuantity (constraints tl pp)
+        . view (#tokens . #tokens) <$> outs
   where
     nl = ctx ^. networkLayer
     tl = ctx ^. transactionLayer @k
@@ -1407,7 +1409,7 @@ selectAssets ctx (utxo, cp, pending) tx outs transform = do
     selectionCriteria <- withExceptT ErrSelectAssetsCriteriaError $ except $
         initSelectionCriteria tl pp tx utxo outs
     sel <- performSelection
-        (calcMinimumCoinValue tl pp)
+        (view #txOutputMinimumAdaQuantity $ constraints tl pp)
         (calcMinimumCost tl pp tx)
         (tokenBundleSizeAssessor tl)
         (selectionCriteria)

diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs
@@ -185,22 +185,22 @@ data SelectionCriteria = SelectionCriteria
 -- output must not change the estimated cost of a selection.
 --
 data SelectionSkeleton = SelectionSkeleton
-    { inputsSkeleton
-        :: !UTxOIndex
-    , outputsSkeleton
+    { skeletonInputCount
+        :: !Int
+    , skeletonOutputs
         :: ![TxOut]
-    , changeSkeleton
+    , skeletonChange
         :: ![Set AssetId]
     }
-    deriving (Eq, Show)
+    deriving (Eq, Generic, Show)
 
 -- | Creates an empty 'SelectionSkeleton' with no inputs, no outputs and no
 -- change.
 emptySkeleton :: SelectionSkeleton
 emptySkeleton = SelectionSkeleton
-    { inputsSkeleton  = UTxOIndex.empty
-    , outputsSkeleton = mempty
-    , changeSkeleton  = mempty
+    { skeletonInputCount = 0
+    , skeletonOutputs = mempty
+    , skeletonChange = mempty
     }
 
 -- | Specifies a limit to adhere to when performing a selection.
@@ -594,12 +594,12 @@ performSelection minCoinFor costFor bundleSizeAssessor criteria
         SelectionState {selected, leftover} = s
 
         requiredCost = costFor SelectionSkeleton
-            { inputsSkeleton  = selected
-            , outputsSkeleton = NE.toList outputsToCover
-            , changeSkeleton
+            { skeletonInputCount = UTxOIndex.size selected
+            , skeletonOutputs = NE.toList outputsToCover
+            , skeletonChange
             }
 
-        changeSkeleton = predictChange selected
+        skeletonChange = predictChange selected
         inputsSelected = mkInputsSelected selected
 
     invariantSelectAnyInputs =

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration.hs
@@ -17,14 +17,13 @@ module Cardano.Wallet.Primitive.Migration
     , MigrationPlan (..)
     , RewardWithdrawal (..)
     , Selection (..)
-    , TxSize (..)
 
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Migration.Selection
-    ( RewardWithdrawal (..), Selection (..), TxSize (..) )
+    ( RewardWithdrawal (..), Selection (..) )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin )
 import Cardano.Wallet.Primitive.Types.Tx
@@ -44,8 +43,8 @@ import qualified Cardano.Wallet.Primitive.Migration.Planning as Planning
 --
 -- See 'createPlan' to create a migration plan.
 --
-data MigrationPlan size = MigrationPlan
-    { selections :: ![Selection (TxIn, TxOut) size]
+data MigrationPlan = MigrationPlan
+    { selections :: ![Selection (TxIn, TxOut)]
       -- ^ A list of generated selections: each selection is the basis for a
       -- single transaction.
     , unselected :: !UTxO
@@ -62,11 +61,10 @@ data MigrationPlan size = MigrationPlan
 -- See 'MigrationPlan'.
 --
 createPlan
-    :: TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> UTxO
     -> RewardWithdrawal
-    -> MigrationPlan size
+    -> MigrationPlan
 createPlan constraints utxo reward = MigrationPlan
     { selections = view #selections plan
     , unselected = Planning.uncategorizeUTxO (view #unselected plan)

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration/Planning.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration/Planning.hs
@@ -39,7 +39,7 @@ module Cardano.Wallet.Primitive.Migration.Planning
 import Prelude
 
 import Cardano.Wallet.Primitive.Migration.Selection
-    ( RewardWithdrawal (..), Selection (..), SelectionError (..), TxSize (..) )
+    ( RewardWithdrawal (..), Selection (..), SelectionError (..) )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
 import Cardano.Wallet.Primitive.Types.TokenBundle
@@ -73,8 +73,8 @@ import qualified Data.Map.Strict as Map
 --
 -- Use 'createPlan' to create a migration plan.
 --
-data MigrationPlan input size = MigrationPlan
-    { selections :: ![Selection input size]
+data MigrationPlan input = MigrationPlan
+    { selections :: ![Selection input]
       -- ^ A list of generated selections: each selection is the basis for a
       -- single transaction.
     , unselected :: !(CategorizedUTxO input)
@@ -91,11 +91,10 @@ data MigrationPlan input size = MigrationPlan
 -- See 'MigrationPlan'.
 --
 createPlan
-    :: TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> CategorizedUTxO input
     -> RewardWithdrawal
-    -> MigrationPlan input size
+    -> MigrationPlan input
 createPlan constraints =
     run []
   where
@@ -117,11 +116,10 @@ createPlan constraints =
 -- entries that remain.
 --
 createSelection
-    :: TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> CategorizedUTxO input
     -> RewardWithdrawal
-    -> Maybe (CategorizedUTxO input, Selection input size)
+    -> Maybe (CategorizedUTxO input, Selection input)
 createSelection constraints utxo rewardWithdrawal =
     initializeSelection constraints utxo rewardWithdrawal
     <&> extendSelectionUntilFull constraints
@@ -132,11 +130,10 @@ createSelection constraints utxo rewardWithdrawal =
 -- UTxO entries that remain.
 --
 initializeSelection
-    :: forall input size. TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> CategorizedUTxO input
     -> RewardWithdrawal
-    -> Maybe (CategorizedUTxO input, Selection input size)
+    -> Maybe (CategorizedUTxO input, Selection input)
 initializeSelection constraints utxoAtStart reward =
     initializeWith =<< utxoAtStart `select` Supporter
   where
@@ -156,10 +153,9 @@ initializeSelection constraints utxoAtStart reward =
 -- is not enough ada to pay for a "freerider" entry.
 --
 extendSelectionUntilFull
-    :: TxSize size
-    => TxConstraints size
-    -> (CategorizedUTxO input, Selection input size)
-    -> (CategorizedUTxO input, Selection input size)
+    :: TxConstraints
+    -> (CategorizedUTxO input, Selection input)
+    -> (CategorizedUTxO input, Selection input)
 extendSelectionUntilFull constraints = extendWithFreerider
   where
     extendWithFreerider (!utxo, !selection) =
@@ -190,11 +186,10 @@ data ExtendSelectionError
     | ExtendSelectionFull
 
 extendWith
-    :: TxSize size
-    => UTxOEntryCategory
-    -> TxConstraints size
-    -> (CategorizedUTxO input, Selection input size)
-    -> Either ExtendSelectionError (CategorizedUTxO input, Selection input size)
+    :: UTxOEntryCategory
+    -> TxConstraints
+    -> (CategorizedUTxO input, Selection input)
+    -> Either ExtendSelectionError (CategorizedUTxO input, Selection input)
 extendWith category constraints (utxo, selection) =
     case utxo `select` category of
         Just (entry, utxo') ->
@@ -250,16 +245,14 @@ data CategorizedUTxO input = CategorizedUTxO
     deriving (Eq, Show)
 
 categorizeUTxO
-    :: TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> UTxO
     -> CategorizedUTxO (TxIn, TxOut)
 categorizeUTxO constraints (UTxO u) = categorizeUTxOEntries constraints $
     (\(i, o) -> ((i, o), view #tokens o)) <$> Map.toList u
 
 categorizeUTxOEntries
-    :: forall input size. TxSize size
-    => TxConstraints size
+    :: forall input. TxConstraints
     -> [(input, TokenBundle)]
     -> CategorizedUTxO input
 categorizeUTxOEntries constraints uncategorizedEntries = CategorizedUTxO
@@ -277,8 +270,7 @@ categorizeUTxOEntries constraints uncategorizedEntries = CategorizedUTxO
         fmap fst <$> L.filter ((== category) . snd . snd) categorizedEntries
 
 categorizeUTxOEntry
-    :: TxSize size
-    => TxConstraints size
+    :: TxConstraints
     -> TokenBundle
     -> UTxOEntryCategory
 categorizeUTxOEntry constraints b