Change signature of coverFee

Lots of commented code.. need to create an `Gen TxBodyContent` first.

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

@@ -73,7 +73,10 @@ import Hydra.Chain.Direct.Util (
   versions,
  )
 import Hydra.Ledger.Cardano (
+  BuildTx,
   NetworkId (Testnet),
+  TxBodyContent,
+  Utxo,
   fromLedgerTxId,
   genKeyPair,
   getTxId,
@@ -150,7 +153,7 @@ data TinyWallet m = TinyWallet
   { getUtxo :: STM m (Map TxIn TxOut)
   , getAddress :: Address
   , sign :: Api.TxBody Api.Era -> Api.Tx Api.Era
-  , coverFee :: Map TxIn TxOut -> ValidatedTx Era -> STM m (Either ErrCoverFee (ValidatedTx Era))
+  , coverFee :: Utxo -> TxBodyContent BuildTx Api.Era -> STM m (Either ErrCoverFee (Api.TxBody Api.Era))
   , verificationKey :: VerificationKey
   }
 
@@ -242,110 +245,112 @@ data ErrCoverFee
 -- TODO: The fee calculation is currently very dumb and static.
 coverFee_ ::
   PParams Era ->
+  Utxo ->
   Map TxIn TxOut ->
-  Map TxIn TxOut ->
-  ValidatedTx Era ->
-  Either ErrCoverFee (Map TxIn TxOut, ValidatedTx Era)
-coverFee_ pparams lookupUtxo walletUtxo partialTx@ValidatedTx{body, wits} = do
-  (input, output) <- case Map.lookupMax (Map.filter hasEnoughValue walletUtxo) of
-    Nothing ->
-      -- TODO(SN): this is misleading as we "just" don't have a Utxo which 'hasEnoughValue'
-      Left ErrNoAvailableUtxo
-    Just (i, o) ->
-      Right (i, o)
-
-  let inputs' = inputs body <> Set.singleton input
-  resolvedInputs <- traverse resolveInput (toList inputs')
-
-  let adjustedRedeemers = adjustRedeemers (inputs body) inputs' (txrdmrs wits)
-      needlesslyHighFee = calculateNeedlesslyHighFee adjustedRedeemers
-
-  change <-
-    first ErrNotEnoughFunds $
-      mkChange output resolvedInputs (toList $ outputs body) needlesslyHighFee
-
-  let outputs' = outputs body <> StrictSeq.singleton change
-      langs =
-        [ l
-        | (_hash, script) <- Map.toList (txscripts wits)
-        , (not . isNativeScript @Era) script
-        , Just l <- [language script]
-        ]
-      finalBody =
-        body
-          { inputs = inputs'
-          , outputs = outputs'
-          , collateral = Set.singleton input
-          , txfee = needlesslyHighFee
-          , scriptIntegrityHash =
-              hashScriptIntegrity
-                pparams
-                (Set.fromList langs)
-                adjustedRedeemers
-                (txdats wits)
-          }
-  pure
-    ( Map.delete input walletUtxo
-    , partialTx
-        { body = finalBody
-        , wits = wits{txrdmrs = adjustedRedeemers}
-        }
-    )
- where
-  -- FIXME: 10 ADAs is arbitrary, just a way to increase the likelihood to cover fees
-  hasEnoughValue :: TxOut -> Bool
-  hasEnoughValue = (> Coin 10_000_000) . getAdaValue
-
-  -- TODO: Do a better fee estimation based on the transaction's content.
-  calculateNeedlesslyHighFee (Redeemers redeemers) =
-    let executionCost = txscriptfee (_prices pparams) $ foldMap snd redeemers
-     in Coin 2_000_000 <> executionCost
-
-  getAdaValue :: TxOut -> Coin
-  getAdaValue (TxOut _ value _) =
-    coin value
-
-  resolveInput :: TxIn -> Either ErrCoverFee TxOut
-  resolveInput i = do
-    case Map.lookup i (lookupUtxo <> walletUtxo) of
-      Nothing -> Left $ ErrUnknownInput i
-      Just o -> Right o
-
-  mkChange ::
-    TxOut ->
-    [TxOut] ->
-    [TxOut] ->
-    Coin ->
-    Either Coin TxOut
-  mkChange (TxOut addr _ datum) resolvedInputs otherOutputs fee
-    -- FIXME: The delta between in and out must be greater than the min utxo value!
-    | totalIn <= totalOut =
-      Left $ totalOut <> invert totalIn
-    | otherwise =
-      Right $ TxOut addr (inject changeOut) datum
-   where
-    totalOut = foldMap getAdaValue otherOutputs <> fee
-    totalIn = foldMap getAdaValue resolvedInputs
-    changeOut = totalIn <> invert totalOut
-
-  adjustRedeemers :: Set TxIn -> Set TxIn -> Redeemers Era -> Redeemers Era
-  adjustRedeemers initialInputs finalInputs (Redeemers initialRedeemers) =
-    Redeemers $ Map.fromList $ map adjustOne $ Map.toList initialRedeemers
-   where
-    sortedInputs = sort $ toList initialInputs
-    sortedFinalInputs = sort $ toList finalInputs
-    differences = List.findIndices (not . uncurry (==)) $ zip sortedInputs sortedFinalInputs
-    adjustOne (ptr@(RdmrPtr t idx), (d, _exUnits))
-      | fromIntegral idx `elem` differences =
-        (RdmrPtr t (idx + 1), (d, maxExecutionUnits))
-      | otherwise =
-        (ptr, (d, maxExecutionUnits))
-
-    maxExecutionUnits :: ExUnits
-    maxExecutionUnits =
-      let ExUnits mem steps = _maxTxExUnits pparams
-          nRedeemers = fromIntegral (Map.size initialRedeemers)
-       in ExUnits (mem `div` nRedeemers) (steps `div` nRedeemers)
+  TxBodyContent BuildTx Api.Era ->
+  Either ErrCoverFee (Map TxIn TxOut, Api.TxBody Api.Era)
+coverFee_ pparams lookupUtxo walletUtxo txContent = do
+  undefined
+
+--  (input, output) <- case Map.lookupMax (Map.filter hasEnoughValue walletUtxo) of
+--    Nothing ->
+--      -- TODO(SN): this is misleading as we "just" don't have a Utxo which 'hasEnoughValue'
+--      Left ErrNoAvailableUtxo
+--    Just (i, o) ->
+--      Right (i, o)
+
+--  let inputs' = inputs body <> Set.singleton input
+--  resolvedInputs <- traverse resolveInput (toList inputs')
+
+--  let adjustedRedeemers = adjustRedeemers (inputs body) inputs' (txrdmrs wits)
+--      needlesslyHighFee = calculateNeedlesslyHighFee adjustedRedeemers
+
+--  change <-
+--    first ErrNotEnoughFunds $
+--      mkChange output resolvedInputs (toList $ outputs body) needlesslyHighFee
+
+--  let outputs' = outputs body <> StrictSeq.singleton change
+--      langs =
+--        [ l
+--        | (_hash, script) <- Map.toList (txscripts wits)
+--        , (not . isNativeScript @Era) script
+--        , Just l <- [language script]
+--        ]
+--      finalBody =
+--        body
+--          { inputs = inputs'
+--          , outputs = outputs'
+--          , collateral = Set.singleton input
+--          , txfee = needlesslyHighFee
+--          , scriptIntegrityHash =
+--              hashScriptIntegrity
+--                pparams
+--                (Set.fromList langs)
+--                adjustedRedeemers
+--                (txdats wits)
+--          }
+--  pure
+--    ( Map.delete input walletUtxo
+--    , partialTx
+--        { body = finalBody
+--        , wits = wits{txrdmrs = adjustedRedeemers}
+--        }
+--    )
+-- where
+--  -- FIXME: 10 ADAs is arbitrary, just a way to increase the likelihood to cover fees
+--  hasEnoughValue :: TxOut -> Bool
+--  hasEnoughValue = (> Coin 10_000_000) . getAdaValue
+
+--  -- TODO: Do a better fee estimation based on the transaction's content.
+--  calculateNeedlesslyHighFee (Redeemers redeemers) =
+--    let executionCost = txscriptfee (_prices pparams) $ foldMap snd redeemers
+--     in Coin 2_000_000 <> executionCost
+
+--  getAdaValue :: TxOut -> Coin
+--  getAdaValue (TxOut _ value _) =
+--    coin value
+
+--  resolveInput :: TxIn -> Either ErrCoverFee TxOut
+--  resolveInput i = do
+--    case Map.lookup i (lookupUtxo <> walletUtxo) of
+--      Nothing -> Left $ ErrUnknownInput i
+--      Just o -> Right o
+
+--  mkChange ::
+--    TxOut ->
+--    [TxOut] ->
+--    [TxOut] ->
+--    Coin ->
+--    Either Coin TxOut
+--  mkChange (TxOut addr _ datum) resolvedInputs otherOutputs fee
+--    -- FIXME: The delta between in and out must be greater than the min utxo value!
+--    | totalIn <= totalOut =
+--      Left $ totalOut <> invert totalIn
+--    | otherwise =
+--      Right $ TxOut addr (inject changeOut) datum
+--   where
+--    totalOut = foldMap getAdaValue otherOutputs <> fee
+--    totalIn = foldMap getAdaValue resolvedInputs
+--    changeOut = totalIn <> invert totalOut
+
+--  adjustRedeemers :: Set TxIn -> Set TxIn -> Redeemers Era -> Redeemers Era
+--  adjustRedeemers initialInputs finalInputs (Redeemers initialRedeemers) =
+--    Redeemers $ Map.fromList $ map adjustOne $ Map.toList initialRedeemers
+--   where
+--    sortedInputs = sort $ toList initialInputs
+--    sortedFinalInputs = sort $ toList finalInputs
+--    differences = List.findIndices (not . uncurry (==)) $ zip sortedInputs sortedFinalInputs
+--    adjustOne (ptr@(RdmrPtr t idx), (d, _exUnits))
+--      | fromIntegral idx `elem` differences =
+--        (RdmrPtr t (idx + 1), (d, maxExecutionUnits))
+--      | otherwise =
+--        (ptr, (d, maxExecutionUnits))
+
+--    maxExecutionUnits :: ExUnits
+--    maxExecutionUnits =
+--      let ExUnits mem steps = _maxTxExUnits pparams
+--          nRedeemers = fromIntegral (Map.size initialRedeemers)
+--       in ExUnits (mem `div` nRedeemers) (steps `div` nRedeemers)
 
 -- | The idea for this wallet client is rather simple:
 --

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-missing-methods #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Hydra.Ledger.Cardano (
@@ -226,6 +225,10 @@ utxoFromTx (Tx body@(ShelleyTxBody _ ledgerBody _ _ _ _) _) =
 utxoMin :: Utxo -> Utxo
 utxoMin = Utxo . uncurry Map.singleton . Map.findMin . utxoMap
 
+-- TODO(SN): not happy with the name, but lookupUtxo is used a lot already
+lookupTxIn :: TxIn -> Utxo -> Maybe (TxOut CtxUTxO Era)
+lookupTxIn i (Utxo m) = Map.lookup i m
+
 --
 -- TxBody
 --
@@ -263,6 +266,12 @@ plutusV1Witness script datum redeemer =
       redeemer
       (ExecutionUnits 0 0)
 
+getTxFee :: TxBody Era -> Lovelace
+getTxFee (TxBody TxBodyContent{txFee}) = fee
+ where
+  -- TODO(SN): how to prove the compiler that there is no `TxFeesImplicitInEra` for non-byron?
+  TxFeeExplicit TxFeesExplicitInAlonzoEra fee = txFee
+
 --
 -- Tx
 --
@@ -478,6 +487,10 @@ toTxDatum = \case
   TxOutDatumNone -> TxOutDatumNone
   TxOutDatumHash sdsie ha -> TxOutDatumHash sdsie ha
 
+-- | Get the value stored in a 'TxOut'.
+getValue :: TxOut ctx Era -> Value
+getValue (TxOut _ value _) = txOutValueToValue value
+
 modifyValue :: (Value -> Value) -> TxOut ctx Era -> TxOut ctx Era
 modifyValue f (TxOut addr value datum) =
   TxOut addr (TxOutValue MultiAssetInAlonzoEra . f $ txOutValueToValue value) datum
@@ -662,6 +675,9 @@ genUtxo = do
     Ledger.TxIn Ledger.StandardCrypto
   setTxId baseId (Ledger.TxIn _ti wo) = Ledger.TxIn baseId wo
 
+genOneUtxo :: Gen Utxo
+genOneUtxo = Utxo . Map.fromList <$> vectorOf 1 arbitrary
+
 -- | Generate utxos owned by the given cardano key.
 genUtxoFor :: VerificationKey PaymentKey -> Gen Utxo
 genUtxoFor vk = do

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

@@ -49,17 +49,14 @@ import Hydra.Ledger.Cardano (
   LedgerCrypto,
   Lovelace (Lovelace),
   ScriptDataSupportedInEra (ScriptDataInAlonzoEra),
-  TxBody (TxBody),
-  TxBodyContent (..),
-  TxFee (TxFeeExplicit),
-  TxFeesExplicitInEra (TxFeesExplicitInAlonzoEra),
   TxOutDatum (TxOutDatum),
   Utxo,
   Utxo' (Utxo),
   describeCardanoTx,
   fromLedgerTx,
   fromPlutusData,
   genAdaOnlyUtxo,
+  getTxFee,
   lovelaceToTxOutValue,
   lovelaceToValue,
   makeTransactionBody,
@@ -126,12 +123,12 @@ spec =
                   False
                     & counterexample ("Wallet error: " <> show err)
                     & counterexample ("Wallet utxo: " <> show walletUtxo)
-                Right (_, tx@(TxBody TxBodyContent{txFee})) ->
-                  let TxFeeExplicit TxFeesExplicitInAlonzoEra fee = txFee
+                Right (_, txBody) ->
+                  let fee = getTxFee txBody
                    in fee < Lovelace 3_000_000
-                        & label (show txFee)
-                        & counterexample ("Tx: " <> show tx)
-                        & counterexample ("Fee: " <> show txFee)
+                        & label (show fee)
+                        & counterexample ("Tx: " <> show txBody)
+                        & counterexample ("Fee: " <> show fee)
 
       prop "is observed" $ \txIn cperiod (party :| parties) cardanoKeys ->
         let params = HeadParameters cperiod (party : parties)