Skip to content
Permalink
Browse files

make sure to consume UTxO as they get picked during fee adjustment (u…

…sing a StateT)
  • Loading branch information...
KtorZ committed Apr 13, 2019
1 parent a54ead3 commit c87b71dd3a3a7c3814b3826d039dfd7b4b1a0e7e
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

@@ -34,7 +35,6 @@ import Cardano.Wallet.Primitive.Types
, TxIn
, TxOut (..)
, UTxO (..)
, balance
, balance'
, distance
, invariant
@@ -45,8 +45,8 @@ import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Except
( ExceptT (..), throwE )
import Control.Monad.Trans.Maybe
( MaybeT (..), runMaybeT )
import Control.Monad.Trans.State
( StateT (..), evalStateT )
import Crypto.Random.Types
( MonadRandom )
import Data.Bifunctor
@@ -197,11 +197,11 @@ senderPaysFee
-> UTxO
-> CoinSelection
-> ExceptT FeeError m CoinSelection
senderPaysFee opt utxo = go where
senderPaysFee opt utxo sel = evalStateT (go sel) utxo where
go
:: MonadRandom m
=> CoinSelection
-> ExceptT FeeError m CoinSelection
-> StateT UTxO (ExceptT FeeError m) CoinSelection
go coinSel@(CoinSelection inps outs chgs) = do
-- 1/
-- We compute fees using all inputs, outputs and changes since
@@ -231,36 +231,27 @@ senderPaysFee opt utxo = go where
-- re-run the algorithm with this new elements and using the initial
-- change plus the extra change brought up by this entry and see if
-- we can now correctly cover fee.
remFee <-
lift $ runMaybeT $ coverRemainingFee (Fee remainingFee) utxo
case remFee of
Nothing -> do
let toPay = remainingFee - fromIntegral (balance utxo)
throwE $ CannotCoverFee toPay
Just inps' -> do
let excessiveAmount = balance' inps' - remainingFee
let extraChange = splitChange (Coin excessiveAmount) chgs'
go $ CoinSelection (inps <> inps') outs extraChange
inps' <- coverRemainingFee (Fee remainingFee)
let extraChange = splitChange (Coin $ balance' inps') chgs
go $ CoinSelection (inps <> inps') outs extraChange

-- | A short / simple version of the 'random' fee policy to cover for fee in
-- case where existing change were not enough.
coverRemainingFee
:: MonadRandom m
=> Fee
-> UTxO
-> MaybeT m [(TxIn, TxOut)]
-> StateT UTxO (ExceptT FeeError m) [(TxIn, TxOut)]
coverRemainingFee (Fee fee) = go [] where
go acc utxo'
go acc
| balance' acc >= fee =
return acc
| otherwise = do
-- We ignore the size of the fee, and just pick randomly
utxoEntryPicked <- lift $ runMaybeT $ pickRandom utxo'
case utxoEntryPicked of
Just (entry, utxo'') ->
go (entry : acc) utxo''
Nothing ->
MaybeT $ return Nothing
StateT (lift . pickRandom) >>= \case
Just entry ->
go (entry : acc)
Nothing -> do
lift $ throwE $ CannotCoverFee (fee - balance' acc)

-- | Reduce the given change outputs by the total fee, returning the remainig
-- change outputs if any are left, or the remaining fee otherwise
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Copyright: © 2018-2019 IOHK
@@ -149,14 +150,14 @@ processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do
| balance' inps >= targetMin target =
MaybeT $ return $ Just (inps, utxo)
| otherwise = do
pickRandom utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo')
pickRandomT utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo')

improve
:: forall m. MonadRandom m
=> ([(TxIn, TxOut)], UTxO)
-> m ([(TxIn, TxOut)], UTxO)
improve (inps, utxo) =
runMaybeT (pickRandom utxo) >>= \case
runMaybeT (pickRandomT utxo) >>= \case
Nothing ->
return (inps, utxo)
Just (io, utxo') | isImprovement io inps -> do
@@ -187,6 +188,11 @@ processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do
Internals
-------------------------------------------------------------------------------}

-- | Re-wrap 'pickRandom' in a 'MaybeT' monad
pickRandomT :: MonadRandom m => UTxO -> MaybeT m ((TxIn, TxOut), UTxO)
pickRandomT =
MaybeT . fmap (\(m,u) -> (,u) <$> m) . pickRandom

-- | Compute the target range for a given output
mkTargetRange :: TxOut -> TargetRange
mkTargetRange (TxOut _ (Coin c)) = TargetRange
@@ -89,10 +89,6 @@ import Prelude

import Control.DeepSeq
( NFData (..) )
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Maybe
( MaybeT (..) )
import Crypto.Hash
( Blake2b_160, Digest, digestFromByteString )
import Crypto.Number.Generate
@@ -505,13 +501,13 @@ instance Buildable UTxO where
pickRandom
:: MonadRandom m
=> UTxO
-> MaybeT m ((TxIn, TxOut), UTxO)
-> m (Maybe (TxIn, TxOut), UTxO)
pickRandom (UTxO utxo)
| Map.null utxo =
MaybeT $ return Nothing
return (Nothing, UTxO utxo)
| otherwise = do
ix <- fromEnum <$> lift (generateBetween 0 (toEnum (Map.size utxo - 1)))
return (Map.elemAt ix utxo, UTxO $ Map.deleteAt ix utxo)
ix <- fromEnum <$> generateBetween 0 (toEnum (Map.size utxo - 1))
return (Just $ Map.elemAt ix utxo, UTxO $ Map.deleteAt ix utxo)

-- | Compute the balance of a UTxO
balance :: UTxO -> Natural
@@ -362,7 +362,7 @@ spec = do
}) (Right $ FeeOutput
{ csInps = [10,10,3,3]
, csOuts = [7,7]
, csChngs = [2]
, csChngs = [1,1]
})

feeUnitTest (FeeFixture

0 comments on commit c87b71d

Please sign in to comment.
You can’t perform that action at this time.