diff --git a/hydra-node/src/Hydra/Chain/Direct/Wallet.hs b/hydra-node/src/Hydra/Chain/Direct/Wallet.hs index 94c7f394d72..db8276503fb 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Wallet.hs +++ b/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: -- diff --git a/hydra-node/src/Hydra/Ledger/Cardano.hs b/hydra-node/src/Hydra/Ledger/Cardano.hs index f3aa6379825..4014e5bf5c5 100644 --- a/hydra-node/src/Hydra/Ledger/Cardano.hs +++ b/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 diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs index c75c583a0d1..4c6e899e688 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs @@ -49,10 +49,6 @@ import Hydra.Ledger.Cardano ( LedgerCrypto, Lovelace (Lovelace), ScriptDataSupportedInEra (ScriptDataInAlonzoEra), - TxBody (TxBody), - TxBodyContent (..), - TxFee (TxFeeExplicit), - TxFeesExplicitInEra (TxFeesExplicitInAlonzoEra), TxOutDatum (TxOutDatum), Utxo, Utxo' (Utxo), @@ -60,6 +56,7 @@ import Hydra.Ledger.Cardano ( 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) diff --git a/hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs b/hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs index a89e1a1ab20..63b790781b2 100644 --- a/hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs @@ -12,12 +12,11 @@ import Cardano.Ledger.Alonzo.TxBody (TxBody (..), pattern TxOut) import Cardano.Ledger.Alonzo.TxSeq (TxSeq (..)) import Cardano.Ledger.Block (bbody) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Core (Value) import Cardano.Ledger.Keys (VKey (..)) import qualified Cardano.Ledger.SafeHash as SafeHash -import Cardano.Ledger.Shelley.API (BHeader) +import Cardano.Ledger.Shelley.API (BHeader, UTxO (unUTxO)) import qualified Cardano.Ledger.Shelley.API as Ledger -import Cardano.Ledger.Val (Val (..), invert) +import Cardano.Ledger.Val (Val (..)) import Control.Monad.Class.MonadTimer (timeout) import Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map @@ -36,7 +35,8 @@ import Hydra.Chain.Direct.Wallet ( watchUtxoUntil, withTinyWallet, ) -import Hydra.Ledger.Cardano (NetworkId (Testnet), NetworkMagic, mkVkAddress, toLedgerAddr) +import Hydra.Ledger.Cardano (NetworkId (Testnet), NetworkMagic, TxBodyContent (..), Utxo, Utxo' (Utxo), fromShelleyTxIn, genOneUtxo, getTxFee, getValue, lookupTxIn, lovelaceToValue, makeTransactionBody, mkVkAddress, negateValue, toLedgerAddr, toLedgerUtxo) +import qualified Hydra.Ledger.Cardano as Api import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..)) import Ouroboros.Consensus.Shelley.Ledger (mkShelleyBlock) import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () @@ -92,7 +92,7 @@ spec = parallel $ do prop_wellSuitedGenerators :: Property prop_wellSuitedGenerators = - forAll genUtxo $ \utxo -> + forAll genUtxo $ \utxo -> do forAllBlind (genBlock utxo) $ \blk -> property (smallTxSets blk) & cover 0.3 (noneIsOurs utxo blk) "has no tx that are ours" @@ -147,27 +147,30 @@ prop_balanceTransaction :: prop_balanceTransaction = forAllBlind (reasonablySized genValidatedTx) $ \tx -> forAllBlind (reasonablySized $ genUtxoFromInputs tx) $ \lookupUtxo -> - forAllBlind (reasonablySized genUtxo) $ \walletUtxo -> - prop' lookupUtxo walletUtxo tx + forAllBlind (reasonablySized genOneUtxo) $ \walletUtxo -> + let arbitraryBodyContents = undefined + in prop' lookupUtxo walletUtxo arbitraryBodyContents where - prop' lookupUtxo walletUtxo tx = - case coverFee_ pparams lookupUtxo walletUtxo tx of + prop' lookupUtxo walletUtxo txDraft = + case coverFee_ pparams lookupUtxo (unUTxO $ toLedgerUtxo walletUtxo) txDraft of Left{} -> property True & label "Left" Right (_, tx') -> let inp' = knownInputBalance (lookupUtxo <> walletUtxo) tx' out' = outputBalance tx' + Right tx = makeTransactionBody txDraft out = outputBalance tx - fee = (txfee . body) tx' + fee = getTxFee tx' + delta = out' <> negateValue inp' in conjoin - [ coin (deltaValue out' inp') == fee + [ delta == lovelaceToValue fee ] & label "Right" & counterexample ("Fee: " <> show fee) - & 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)) + & counterexample ("Delta value: " <> show delta) + & counterexample ("Added value: " <> show inp') + & counterexample ("Outputs after: " <> show out') + & counterexample ("Outputs before: " <> show out) -- -- Generators @@ -221,11 +224,11 @@ genBlock utxo = scale (round @Double . sqrt . fromIntegral) $ do genUtxo :: Gen (Map TxIn TxOut) genUtxo = Map.fromList <$> vectorOf 1 arbitrary -genUtxoFromInputs :: ValidatedTx Era -> Gen (Map TxIn TxOut) +genUtxoFromInputs :: ValidatedTx Era -> Gen Utxo genUtxoFromInputs ValidatedTx{body} = do let n = Set.size (inputs body) outs <- vectorOf n arbitrary - pure $ Map.fromList $ zip (toList (inputs body)) outs + pure $ Utxo . Map.fromList $ zip (map fromShelleyTxIn $ toList (inputs body)) outs genValidatedTx :: Gen (ValidatedTx Era) genValidatedTx = do @@ -287,22 +290,17 @@ 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 - | coin a > coin b = a <> invert b - | otherwise = invert a <> b +-- TODO(SN): candidates to move into our Cardano module -- | NOTE: This does not account for withdrawals -knownInputBalance :: Map TxIn TxOut -> ValidatedTx Era -> Value Era -knownInputBalance utxo = foldMap resolve . toList . inputs . body +knownInputBalance :: Utxo -> Api.TxBody Api.Era -> Api.Value +knownInputBalance utxo (Api.TxBody TxBodyContent{txIns}) = + foldMap (resolve . fst) txIns where - resolve :: TxIn -> Value Era - resolve k = maybe zero getValue (Map.lookup k utxo) + resolve :: Api.TxIn -> Api.Value + resolve k = maybe mempty getValue (lookupTxIn k utxo) -- | NOTE: This does not account for deposits -outputBalance :: ValidatedTx Era -> Value Era -outputBalance = - foldMap getValue . outputs . body +outputBalance :: Api.TxBody Api.Era -> Api.Value +outputBalance (Api.TxBody TxBodyContent{txOuts}) = + foldMap getValue txOuts