Add a function to cover for transaction fee.

  Very simply, for now, it simply add a new input and corresponding change output, leaving some static fee aside.

hydra-node/src/Hydra/Chain/Direct/Wallet.hs

@@ -8,12 +8,14 @@ import qualified Cardano.Crypto.DSIGN as Crypto
 import Cardano.Crypto.Hash.Class (Hash (..))
 import qualified Cardano.Ledger.Address as Ledger
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
-import Cardano.Ledger.Alonzo.TxBody (inputs, outputs, pattern TxOut)
+import Cardano.Ledger.Alonzo.TxBody (collateral, inputs, outputs, txfee, pattern TxOut)
 import Cardano.Ledger.Alonzo.TxSeq (TxSeq (..))
+import Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Core as Ledger
 import Cardano.Ledger.Crypto (DSIGN, StandardCrypto)
 import qualified Cardano.Ledger.Keys as Ledger
 import qualified Cardano.Ledger.SafeHash as SafeHash
+import Cardano.Ledger.Val (Val (..), invert)
 import Control.Monad.Class.MonadSTM (
   check,
   newEmptyTMVarIO,
@@ -96,6 +98,7 @@ data TinyWallet m = TinyWallet
   { getUtxo :: STM m (Map TxIn TxOut)
   , getAddress :: Address
   , sign :: TxBody -> VkWitness
+  , coverFee :: TxBody -> STM m (Either ErrCoverFee TxBody)
   }
 
 withTinyWallet ::
@@ -133,6 +136,8 @@ withTinyWallet magic (vk, sk) iocp addr action = do
       , sign = \body ->
           let txid = Ledger.TxId (SafeHash.hashAnnotated body)
            in txid `signWith` Ledger.KeyPair (Ledger.VKey vk) sk
+      , coverFee = \body ->
+          coverFee_ <$> readTMVar utxoVar <*> pure body
       }
 
 -- | Apply a block to our wallet. Does nothing if the transaction does not
@@ -155,6 +160,50 @@ applyBlock blk isOurs utxo = case blk of
   _ ->
     utxo
 
+data ErrCoverFee
+  = ErrNoAvailableUtxo
+  | ErrNotEnoughFunds {missingDelta :: Coin}
+  deriving (Show)
+
+-- | Cover fee for a transaction body using the given UTXO set. This calculate
+-- necessary fees and augments inputs / outputs / collateral accordingly to
+-- cover for the transaction cost and get the change back.
+--
+-- TODO: The fee calculation is currently very dumb and static.
+coverFee_ ::
+  Map TxIn TxOut ->
+  TxBody ->
+  Either ErrCoverFee TxBody
+coverFee_ utxo body = do
+  (input, output) <- case Map.lookupMax utxo of
+    Nothing ->
+      Left ErrNoAvailableUtxo
+    Just (i, o) ->
+      Right (i, o)
+  change <- first ErrNotEnoughFunds $ mkChange output needlesslyHighFee
+
+  let inputs' = inputs body <> Set.singleton input
+  let outputs' = outputs body <> StrictSeq.singleton change
+
+  pure $
+    body
+      { inputs = inputs'
+      , outputs = outputs'
+      , collateral = Set.singleton input
+      , txfee = needlesslyHighFee
+      }
+ where
+  -- TODO: Do a better fee estimation based on the transaction's content.
+  needlesslyHighFee :: Coin
+  needlesslyHighFee = Coin 2_000_000
+
+  mkChange :: TxOut -> Coin -> Either Coin TxOut
+  mkChange (TxOut addr value datum) fee
+    | coin value > fee =
+      Right $ TxOut addr (value <> invert (inject fee)) datum
+    | otherwise =
+      Left (fee <> invert (coin value))
+
 -- | The idea for this wallet client is rather simple:
 --
 -- 1. We bootstrap the client using the Local State Query (abbrev. LSQ) protocol,

hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs

@@ -3,14 +3,17 @@
 
 module Hydra.Chain.Direct.WalletSpec where
 
-import Hydra.Prelude
+import Hydra.Prelude hiding (label)
 import Test.Hydra.Prelude
 
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
 import Cardano.Ledger.Alonzo.TxBody (TxBody (..), pattern TxOut)
 import Cardano.Ledger.Alonzo.TxSeq (TxSeq (..))
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Core (Value)
 import Cardano.Ledger.Keys (KeyPair (..), VKey (..))
 import qualified Cardano.Ledger.SafeHash as SafeHash
+import Cardano.Ledger.Val (Val (..), invert)
 import Control.Monad.Class.MonadSTM (check)
 import Control.Monad.Class.MonadTimer (timeout)
 import qualified Data.Map.Strict as Map
@@ -25,6 +28,7 @@ import Hydra.Chain.Direct.Wallet (
   TxOut,
   VerificationKey,
   applyBlock,
+  coverFee_,
   withTinyWallet,
  )
 import Hydra.Ledger.Cardano (genKeyPair, mkVkAddress)
@@ -38,25 +42,32 @@ import Test.QuickCheck (
   Gen,
   Property,
   checkCoverage,
+  conjoin,
   counterexample,
   cover,
   forAll,
   forAllBlind,
   frequency,
   generate,
   getSize,
+  label,
   property,
   scale,
   vectorOf,
  )
 
 spec :: Spec
 spec = parallel $ do
+  describe "genBlock / genUtxo" $ do
+    prop "are well-suited for testing" prop_wellSuitedGenerators
+
   describe "applyBlock" $ do
-    prop "uses a well-suited generator for testing" prop_wellSuitedGenerator
     prop "only reduces the UTXO set when no address is ours" prop_reducesWhenNotOurs
     prop "Seen inputs are consumed and not in the resulting UTXO" prop_seenInputsAreConsumed
 
+  describe "coverFee" $ do
+    prop "preserve funds after balancing" prop_preserveFunds
+
   describe "withTinyWallet" $ do
     KeyPair (VKey vk) sk <- runIO $ generate genKeyPair
     it "connects to server and returns UTXO in a timely manner" $ do
@@ -72,9 +83,13 @@ spec = parallel $ do
           result <- timeout 1 $ watchUtxoUntil (not . null) wallet
           result `shouldSatisfy` isJust
 
-prop_wellSuitedGenerator ::
+--
+-- Generators
+--
+
+prop_wellSuitedGenerators ::
   Property
-prop_wellSuitedGenerator =
+prop_wellSuitedGenerators =
   forAll genUtxo $ \utxo ->
     forAllBlind (genBlock utxo) $ \blk ->
       property (smallTxSets blk)
@@ -95,6 +110,10 @@ prop_wellSuitedGenerator =
   someAreDependent utxo blk =
     length (ourDirectInputs utxo blk) < length (ourOutputs utxo blk)
 
+--
+-- applyBlocks
+--
+
 prop_reducesWhenNotOurs ::
   Property
 prop_reducesWhenNotOurs =
@@ -117,6 +136,34 @@ prop_seenInputsAreConsumed =
             & counterexample ("Seen inputs: " <> show seenInputs)
             & counterexample ("New UTXO:    " <> show utxo')
 
+--
+-- coverFee
+--
+
+prop_preserveFunds ::
+  Property
+prop_preserveFunds =
+  forAllBlind genTxBody $ \body ->
+    forAllBlind genUtxo $ \utxo ->
+      prop' utxo body
+ where
+  prop' utxo body =
+    case coverFee_ utxo body of
+      Left{} ->
+        property True & label "Left"
+      Right body' ->
+        let inp' = knownInputBalance utxo body'
+            out' = outputBalance body'
+            out = outputBalance body
+         in conjoin
+              [ deltaValue out' inp' == out
+              ]
+              & label "Right"
+              & counterexample ("Delta value:     " <> show (coin $ deltaValue out' inp'))
+              & counterexample ("Added value:     " <> show (coin inp'))
+              & counterexample ("Outputs after:   " <> show (coin out'))
+              & counterexample ("Outputs before:  " <> show (coin out))
+
 --
 -- Generators
 --
@@ -169,6 +216,11 @@ genBlock utxo = scale (round @Double . sqrt . fromIntegral) $ do
 genUtxo :: Gen (Map TxIn TxOut)
 genUtxo = Map.fromList <$> vectorOf 1 arbitrary
 
+genTxBody :: Gen (TxBody Era)
+genTxBody = do
+  tx <- arbitrary
+  pure $ tx{txfee = Coin 0}
+
 genPaymentTo :: VerificationKey -> Gen (ValidatedTx Era)
 genPaymentTo vk = do
   let myAddr = mkVkAddress (VKey vk)
@@ -215,6 +267,24 @@ ourOutputs utxo blk =
   let ours = Map.elems utxo
    in filter (`elem` ours) (allTxOuts blk)
 
+getValue :: TxOut -> Value Era
+getValue (TxOut _ value _) = value
+
+deltaValue :: Value Era -> Value Era -> Value Era
+deltaValue a b = a <> invert b
+
+-- | NOTE: This does not account for withdrawals
+knownInputBalance :: Map TxIn TxOut -> TxBody Era -> Value Era
+knownInputBalance utxo = fold . fmap resolve . toList . inputs
+ where
+  resolve :: TxIn -> Value Era
+  resolve k = maybe zero getValue (Map.lookup k utxo)
+
+-- | NOTE: This does not account for deposits
+outputBalance :: TxBody Era -> Value Era
+outputBalance body =
+  (fold . fmap getValue . outputs) body <> (inject . txfee) body
+
 watchUtxoUntil :: (Map TxIn TxOut -> Bool) -> TinyWallet IO -> IO (Map TxIn TxOut)
 watchUtxoUntil predicate TinyWallet{getUtxo} = atomically $ do
   u <- getUtxo