From 293baa788b765891525f1e4a46f32c92b4fc3b7a Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 11 May 2023 15:08:05 +0200 Subject: [PATCH] Completely drop Cardano.ProtocolParameters --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 138 ++++----- lib/wallet/src/Cardano/Wallet.hs | 268 +++++++++--------- .../src/Cardano/Wallet/Byron/Compatibility.hs | 16 +- .../src/Cardano/Wallet/Primitive/Types.hs | 14 +- .../Cardano/Wallet/Shelley/Compatibility.hs | 37 ++- .../Cardano/Wallet/Shelley/Network/Node.hs | 30 +- .../Wallet/Write/ProtocolParameters.hs | 32 +-- lib/wallet/src/Cardano/Wallet/Write/Tx.hs | 31 ++ .../Wallet/DummyTarget/Primitive/Types.hs | 7 +- .../test/unit/Cardano/Wallet/DB/Arbitrary.hs | 6 +- .../Cardano/Wallet/Shelley/TransactionSpec.hs | 4 +- 11 files changed, 275 insertions(+), 308 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs index 54cb2ef2b54..da2ab186845 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs @@ -1775,18 +1775,20 @@ selectCoins -> ApiSelectCoinsPayments n -> Handler (ApiCoinSelection n) selectCoins ctx@ApiLayer {..} argGenChange (ApiT walletId) body = do - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (_ :: Write.RecentEra e) <- guardIsRecentEra era withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> do let db = workerCtx ^. dbLayer - ti = timeInterpreter netLayer - timeTranslation <- liftIO $ toTimeTranslation ti - pp <- liftIO $ NW.currentProtocolParameters (workerCtx ^. networkLayer) + + (Write.InAnyRecentEra era pp, timeTranslation) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer + + let anyCardanoEra = Cardano.AnyCardanoEra + $ Write.cardanoEraFromRecentEra era + withdrawal <- body ^. #withdrawal & maybe (pure NoWithdrawal) (shelleyOnlyMkWithdrawal @s - netLayer (txWitnessTagFor @k) db era) + netLayer (txWitnessTagFor @k) db anyCardanoEra) let genChange = W.defaultChangeAddressGen argGenChange let paymentOuts = NE.toList $ addressAmountToTxOut <$> body ^. #payments let txCtx = defaultTransactionCtx @@ -1794,14 +1796,14 @@ selectCoins ctx@ApiLayer {..} argGenChange (ApiT walletId) body = do , txMetadata = getApiT <$> body ^. #metadata } - (cardanoTx, walletState) <- liftIO $ W.buildTransaction @s @e + (cardanoTx, walletState) <- liftIO $ W.buildTransaction @s db txLayer timeTranslation genChange pp txCtx paymentOuts let W.CoinSelection{..} = W.buildCoinSelectionForTransaction @s @n walletState paymentOuts - (W.stakeKeyDeposit pp) + (W.getStakeKeyDeposit pp) Nothing -- delegation action cardanoTx @@ -1839,16 +1841,13 @@ selectCoinsForJoin selectCoinsForJoin ctx@ApiLayer{..} knownPools getPoolStatus poolId walletId = do -- - era <- liftIO $ NW.currentNodeEra netLayer poolStatus <- liftIO $ getPoolStatus poolId pools <- liftIO knownPools curEpoch <- getCurrentEpoch ctx - AnyRecentEra (_ :: Write.RecentEra e) <- guardIsRecentEra era + (Write.InAnyRecentEra _era pp, timeTranslation) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do let db = workerCtx ^. typed @(DBLayer IO s) - timeTranslation <- liftIO $ - toTimeTranslation (timeInterpreter netLayer) - pp <- NW.currentProtocolParameters netLayer action <- liftIO $ WD.joinStakePoolDelegationAction @s (contramap MsgWallet $ workerCtx ^. logger) db @@ -1862,7 +1861,7 @@ selectCoinsForJoin ctx@ApiLayer{..} let paymentOuts = [] - (cardanoTx, walletState) <- W.buildTransaction @s @e + (cardanoTx, walletState) <- W.buildTransaction @s db txLayer timeTranslation changeAddrGen pp txCtx paymentOuts @@ -1870,7 +1869,7 @@ selectCoinsForJoin ctx@ApiLayer{..} W.buildCoinSelectionForTransaction @s @n walletState paymentOuts - (W.stakeKeyDeposit pp) + (W.getStakeKeyDeposit pp) (Just action) cardanoTx @@ -1901,15 +1900,14 @@ selectCoinsForQuit -> ApiT WalletId -> Handler (ApiCoinSelection n) selectCoinsForQuit ctx@ApiLayer{..} (ApiT walletId) = do - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (_ :: Write.RecentEra e) <- guardIsRecentEra era + (Write.InAnyRecentEra era pp, timeTranslation) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer + let anyCardanoEra = Cardano.AnyCardanoEra + $ Write.cardanoEraFromRecentEra era withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do let db = workerCtx ^. typed @(DBLayer IO s) - timeTranslation <- liftIO $ - toTimeTranslation (timeInterpreter netLayer) - pp <- NW.currentProtocolParameters netLayer withdrawal <- W.shelleyOnlyMkSelfWithdrawal @s - netLayer (txWitnessTagFor @k) era db + netLayer (txWitnessTagFor @k) anyCardanoEra db action <- WD.quitStakePoolDelegationAction db withdrawal let changeAddrGen = W.defaultChangeAddressGen (delegationAddressS @n) let txCtx = defaultTransactionCtx @@ -1919,14 +1917,14 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT walletId) = do let paymentOuts = [] - (cardanoTx, walletState) <- W.buildTransaction @s @e + (cardanoTx, walletState) <- W.buildTransaction @s db txLayer timeTranslation changeAddrGen pp txCtx paymentOuts let W.CoinSelection{..} = W.buildCoinSelectionForTransaction @s @n walletState paymentOuts - (W.stakeKeyDeposit pp) + (W.getStakeKeyDeposit pp) (Just action) cardanoTx @@ -2186,8 +2184,6 @@ postTransactionOld ctx@ApiLayer{..} argGenChange (ApiT wid) body = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (recentEra :: Write.RecentEra era) - <- guardIsRecentEra era ttl <- liftIO $ W.transactionExpirySlot ti mTTL wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal @@ -2208,7 +2204,6 @@ postTransactionOld ctx@ApiLayer{..} argGenChange (ApiT wid) body = do (coerce $ getApiT $ body ^. #passphrase) wid (W.defaultChangeAddressGen argGenChange) - (AnyRecentEra recentEra) (PreSelection $ NE.toList outs) txCtx @@ -2361,30 +2356,32 @@ postTransactionFeeOld -> PostTransactionFeeOldData n -> Handler ApiFee postTransactionFeeOld ctx@ApiLayer{..} (ApiT walletId) body = do - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (recentEra :: Write.RecentEra era) <- guardIsRecentEra era - (protocolParameters, _bundledProtocolParameters) <- liftIO $ - W.toBalanceTxPParams @era <$> currentProtocolParameters netLayer + (Write.InAnyRecentEra era pp, timeTranslation) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer + + -- Needed only for calcMinimumCoinValues. We'd ideally use the ledger @pp@ + -- above instead. + walletPP <- liftIO $ currentProtocolParameters netLayer + + let anyCardanoEra = Cardano.AnyCardanoEra + $ Write.cardanoEraFromRecentEra era let mTTL = body ^? #timeToLive . traverse . #getQuantity withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> do let db = workerCtx ^. dbLayer - timeTranslation <- liftIO $ - toTimeTranslation (timeInterpreter netLayer) ttl <- liftIO $ W.transactionExpirySlot (timeInterpreter netLayer) mTTL wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> shelleyOnlyMkWithdrawal @s - netLayer (txWitnessTagFor @k) db era apiWdrl + netLayer (txWitnessTagFor @k) db anyCardanoEra apiWdrl let outputs = F.toList $ addressAmountToTxOut <$> body ^. #payments - minCoins = W.calcMinimumCoinValues protocolParameters txLayer era + minCoins = W.calcMinimumCoinValues walletPP txLayer anyCardanoEra <$> outputs feePercentiles <- liftIO $ W.transactionFee @s db - (Write.unsafeFromWalletProtocolParameters protocolParameters) + pp txLayer timeTranslation - recentEra dummyChangeAddressGen defaultTransactionCtx { txWithdrawal = wdrl @@ -2395,7 +2392,10 @@ postTransactionFeeOld ctx@ApiLayer{..} (ApiT walletId) body = do PreSelection{outputs} pure $ mkApiFee Nothing minCoins - $ W.padFeePercentiles protocolParameters padding feePercentiles + $ W.padFeePercentiles + (Write.getFeePerByte era $ Write.pparamsLedger pp) + padding + feePercentiles where -- Padding to make the fee percentiles more imprecise, for the following -- reasons: @@ -2464,16 +2464,19 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d netLayer = wrk ^. networkLayer txLayer = wrk ^. transactionLayer @_ @'CredFromKeyK trWorker = MsgWallet >$< wrk ^. logger - pp <- liftIO $ NW.currentProtocolParameters netLayer - era <- liftIO $ NW.currentNodeEra netLayer + + (Write.InAnyRecentEra (era :: Write.RecentEra era) pp, _) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer + + let anyCardanoEra = Cardano.AnyCardanoEra + $ Write.cardanoEraFromRecentEra era + epoch <- getCurrentEpoch api - AnyRecentEra (_recentEra :: Write.RecentEra era) - <- guardIsRecentEra era withdrawal <- case body ^. #withdrawal of Just SelfWithdraw -> liftIO $ W.shelleyOnlyMkSelfWithdrawal - netLayer (txWitnessTagFor @k) era db + netLayer (txWitnessTagFor @k) anyCardanoEra db _ -> pure NoWithdrawal let transactionCtx0 = defaultTransactionCtx @@ -2586,11 +2589,11 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d (_, _, rewardPath) <- handler $ W.readRewardAccount @n db let deposits = case txDelegationAction transactionCtx2 of - Just (JoinRegisteringKey _poolId) -> [W.stakeKeyDeposit pp] + Just (JoinRegisteringKey _poolId) -> [W.getStakeKeyDeposit pp] _ -> [] let refunds = case txDelegationAction transactionCtx2 of - Just Quit -> [W.stakeKeyDeposit pp] + Just Quit -> [W.getStakeKeyDeposit pp] _ -> [] pure ApiConstructTransaction @@ -2885,11 +2888,9 @@ constructSharedTransaction txLayer = wrk ^. transactionLayer @SharedKey @'CredFromScriptK trWorker = MsgWallet >$< wrk ^. logger - pp <- liftIO $ NW.currentProtocolParameters netLayer epoch <- getCurrentEpoch api - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - AnyRecentEra (_recentEra :: Write.RecentEra era) - <- guardIsRecentEra era + (Write.InAnyRecentEra (_ :: Write.RecentEra era) pp, _) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer (cp, _, _) <- handler $ W.readWallet wrk let delegationTemplateM = Shared.delegationTemplate $ getState cp when (isNothing delegationTemplateM && isJust delegationRequest) $ @@ -2940,10 +2941,10 @@ constructSharedTransaction apiDecoded <- decodeSharedTransaction api (ApiT wid) balancedTx let deposits = case optionalDelegationAction of Just (JoinRegisteringKey _poolId) -> - [W.stakeKeyDeposit pp] + [W.getStakeKeyDeposit pp] _ -> [] let refunds = case optionalDelegationAction of - Just Quit -> [W.stakeKeyDeposit pp] + Just Quit -> [W.getStakeKeyDeposit pp] _ -> [] delCerts <- case optionalDelegationAction of Nothing -> pure Nothing @@ -3081,23 +3082,19 @@ balanceTransaction -> Handler ApiSerialisedTransaction balanceTransaction ctx@ApiLayer{..} argGenChange utxoAssumptions (ApiT wid) body = do - -- NOTE: Ideally we'd read @pp@ and @era@ atomically. - pp <- liftIO $ currentProtocolParameters netLayer - era <- liftIO $ NW.currentNodeEra netLayer - Write.AnyRecentEra recentEra <- guardIsRecentEra era + (Write.InAnyRecentEra recentEra pp, timeTranslation) + <- liftIO $ W.readNodeTipStateForTxWrite netLayer withWorkerCtx ctx wid liftE liftE $ \wrk -> do (utxo, wallet, _txs) <- handler $ W.readWalletUTxO wrk - timeTranslation <- liftIO $ toTimeTranslation (timeInterpreter netLayer) partialTx <- parsePartialTx recentEra - balancedTx <- liftHandler . fmap (Cardano.InAnyCardanoEra Write.cardanoEra . fst) $ Write.balanceTransaction (MsgWallet . W.MsgBalanceTx >$< wrk ^. W.logger) utxoAssumptions - (Write.unsafeFromWalletProtocolParameters pp) + pp timeTranslation (Write.constructUTxOIndex utxo) (W.defaultChangeAddressGen argGenChange) @@ -3509,10 +3506,6 @@ joinStakePool poolStatus <- liftIO (getPoolStatus poolId) pools <- liftIO knownPools curEpoch <- getCurrentEpoch ctx - -- FIXME [ADP-1489] pp and era are not guaranteed to be consistent, - -- which could cause problems under exceptional circumstances. - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (recentEra :: Write.RecentEra era) <- guardIsRecentEra era withWorkerCtx ctx walletId liftE liftE $ \wrk -> do let tr = wrk ^. logger db = wrk ^. typed @(DBLayer IO s) @@ -3525,7 +3518,6 @@ joinStakePool (coerce $ getApiT $ body ^. #passphrase) walletId (W.defaultChangeAddressGen argGenChange) - (AnyRecentEra recentEra) (PreSelection []) =<< WD.joinStakePool (MsgWallet >$< tr) @@ -3568,18 +3560,12 @@ delegationFee -> ApiT WalletId -> Handler ApiFee delegationFee ctx@ApiLayer{..} (ApiT walletId) = do - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (recentEra :: Write.RecentEra era) <- guardIsRecentEra era withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do - timeTranslation <- - toTimeTranslation (timeInterpreter netLayer) W.DelegationFee {feePercentiles, deposit} <- W.delegationFee @s (workerCtx ^. dbLayer) netLayer txLayer - timeTranslation - (AnyRecentEra recentEra) (W.defaultChangeAddressGen (delegationAddressS @n)) pure $ mkApiFee (Just deposit) [] feePercentiles @@ -3598,8 +3584,6 @@ quitStakePool -> ApiWalletPassphrase -> Handler (ApiTransaction n) quitStakePool ctx@ApiLayer{..} argGenChange (ApiT walletId) body = do - era <- liftIO $ NW.currentNodeEra netLayer - AnyRecentEra (recentEra :: Write.RecentEra era) <- guardIsRecentEra era withWorkerCtx ctx walletId liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO s) ti = timeInterpreter netLayer @@ -3612,7 +3596,6 @@ quitStakePool ctx@ApiLayer{..} argGenChange (ApiT walletId) body = do (coerce $ getApiT $ body ^. #passphrase) walletId (W.defaultChangeAddressGen argGenChange) - (AnyRecentEra recentEra) (PreSelection []) txCtx @@ -4204,19 +4187,6 @@ type RewardAccountBuilder k = (k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption") - -guardIsRecentEra :: AnyCardanoEra -> Handler AnyRecentEra -guardIsRecentEra (Cardano.AnyCardanoEra era) = case era of - Cardano.ConwayEra -> pure $ Write.AnyRecentEra Write.RecentEraConway - Cardano.BabbageEra -> pure $ Write.AnyRecentEra Write.RecentEraBabbage - Cardano.AlonzoEra -> liftE invalidEra - Cardano.MaryEra -> liftE invalidEra - Cardano.AllegraEra -> liftE invalidEra - Cardano.ShelleyEra -> liftE invalidEra - Cardano.ByronEra -> liftE invalidEra - where - invalidEra = W.ErrNodeNotYetInRecentEra $ Cardano.AnyCardanoEra era - mkWithdrawal :: forall n block . NetworkLayer IO block diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index b9c4415a438..197d95b124d 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -136,6 +136,7 @@ module Cardano.Wallet , assignChangeAddressesAndUpdateDb , assignChangeAddressesWithoutDbUpdate , selectionToUnsignedTx + , readNodeTipStateForTxWrite , buildSignSubmitTransaction , buildTransaction , buildTransactionPure @@ -170,6 +171,7 @@ module Cardano.Wallet , Percentile (..) , DelegationFee (..) , delegationFee + , getStakeKeyDeposit , transactionFee , calculateFeePercentiles , padFeePercentiles @@ -213,7 +215,6 @@ module Cardano.Wallet -- * Utilities , throttle , guardHardIndex - , toBalanceTxPParams , utxoAssumptionsForWallet -- * Logging @@ -417,9 +418,7 @@ import Cardano.Wallet.Primitive.Types , BlockHeader (..) , ChainPoint (..) , DelegationCertificate (..) - , FeePolicy (..) , GenesisParameters (..) - , LinearFunction (..) , NetworkParameters (..) , ProtocolParameters (..) , Range (..) @@ -505,7 +504,7 @@ import Cardano.Wallet.Transaction.Built import Cardano.Wallet.TxWitnessTag ( TxWitnessTag ) import Cardano.Wallet.Write.Tx - ( AnyRecentEra ) + ( recentEra ) import Cardano.Wallet.Write.Tx.Balance ( BalanceTxLog (..) , ChangeAddressGen (..) @@ -579,6 +578,8 @@ import Data.Generics.Labels () import Data.Generics.Product.Typed ( HasType, typed ) +import Data.IntCast + ( intCast ) import Data.List ( foldl' ) import Data.List.NonEmpty @@ -1881,6 +1882,24 @@ data ErrWriteTxEra -- but would require some work. deriving (Show, Eq) +readNodeTipStateForTxWrite + :: NetworkLayer IO Read.Block + -> IO (Write.InAnyRecentEra Write.ProtocolParameters, TimeTranslation) +readNodeTipStateForTxWrite netLayer = do + let ti = timeInterpreter netLayer + timeTranslation <- toTimeTranslation ti + + res <- currentLedgerProtocolParameters + <$> currentProtocolParameters netLayer + + case Write.toRecentEraGADT res of + Right pp -> + pure (pp, timeTranslation) + Left era -> throwIO $ invalidEra era + where + invalidEra = ExceptionWriteTxEra + . ErrNodeNotYetInRecentEra + -- | Build, Sign, Submit transaction. -- -- Requires the encryption passphrase in order to decrypt the root private key. @@ -1901,18 +1920,16 @@ buildSignSubmitTransaction -> Passphrase "user" -> WalletId -> ChangeAddressGen s - -> AnyRecentEra -> PreSelection -> TransactionCtx -> IO (BuiltTx, UTCTime) -buildSignSubmitTransaction db@DBLayer{..} netLayer txLayer pwd walletId - changeAddrGen era preSelection txCtx = do +buildSignSubmitTransaction db@DBLayer{..} netLayer txLayer + pwd walletId changeAddrGen preSelection txCtx = do -- stdGen <- initStdGen - protocolParameters <- currentProtocolParameters netLayer + (Write.InAnyRecentEra _era protocolParams, timeTranslation) + <- readNodeTipStateForTxWrite netLayer let ti = timeInterpreter netLayer - timeTranslation <- toTimeTranslation ti - throwOnErr <=< runExceptT $ withRootKey db walletId pwd wrapRootKeyError $ \rootKey scheme -> lift $ do (BuiltTx{..}, slot) <- atomically $ do @@ -1934,10 +1951,9 @@ buildSignSubmitTransaction db@DBLayer{..} netLayer txLayer pwd walletId rootKey scheme pwd - protocolParameters + protocolParams txLayer changeAddrGen - era preSelection txCtx & (`runStateT` wallet) @@ -1977,7 +1993,7 @@ buildSignSubmitTransaction db@DBLayer{..} netLayer txLayer pwd walletId wrapBalanceConstructError = either ExceptionBalanceTx ExceptionConstructTx buildAndSignTransactionPure - :: forall k s + :: forall k s era . ( HardDerivation k , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) , IsOwned s k 'CredFromKeyK @@ -1986,16 +2002,16 @@ buildAndSignTransactionPure , HardDerivation k , IsOurs s RewardAccount , WalletFlavor s + , Write.IsRecentEra era ) => TimeTranslation -> UTxO -> k 'RootK XPrv -> PassphraseScheme -> Passphrase "user" - -> ProtocolParameters + -> Write.ProtocolParameters era -> TransactionLayer k 'CredFromKeyK SealedTx -> ChangeAddressGen s - -> AnyRecentEra -> PreSelection -> TransactionCtx -> StateT @@ -2003,81 +2019,77 @@ buildAndSignTransactionPure (ExceptT (Either ErrBalanceTx ErrConstructTx) (Rand StdGen)) BuiltTx buildAndSignTransactionPure - timeTranslation utxo rootKey passphraseScheme userPassphrase - protocolParams txLayer changeAddrGen era preSelection txCtx = - -- - Write.withRecentEra era $ \(_ :: Write.RecentEra recentEra) -> do - wallet <- get - (unsignedBalancedTx, updatedWalletState) <- lift $ - buildTransactionPure @s @recentEra - wallet timeTranslation utxo txLayer changeAddrGen - (Write.unsafeFromWalletProtocolParameters protocolParams) - preSelection txCtx - put wallet { getState = updatedWalletState } - - let mExternalRewardAccount = case view #txWithdrawal txCtx of - WithdrawalExternal _ _ _ externalXPrv - -> Just (externalXPrv, mempty) -- no passphrase - _ - -> Nothing - - let passphrase = preparePassphrase passphraseScheme userPassphrase - signedTx = signTransaction @k @'CredFromKeyK - (keyFlavorFromState @s) - txLayer - anyCardanoEra - AnyWitnessCountCtx - (isOwned (getState wallet) (rootKey, passphrase)) - mExternalRewardAccount - (rootKey, passphrase) - (wallet ^. #utxo) - Nothing - (sealedTxFromCardano $ inAnyCardanoEra unsignedBalancedTx) - - let ( tx - , _tokenMapWithScripts1 - , _tokenMapWithScripts2 - , _certificates - , _validityIntervalExplicit - , _witnessCount - ) = decodeTx txLayer anyCardanoEra AnyWitnessCountCtx signedTx - - let utxo' = applyOurTxToUTxO - (Slot.at $ currentTip wallet ^. #slotNo) - (currentTip wallet ^. #blockHeight) - (getState wallet) - tx - (wallet ^. #utxo) - meta = case utxo' of - Nothing -> error $ unwords - [ "buildAndSignTransactionPure:" - , "Can't apply constructed transaction." - ] - Just ((_tx, appliedMeta), _deltaUtxo, _nextUtxo) -> - appliedMeta - { status = Pending - , expiry = Just (snd (txValidityInterval txCtx)) - } - - -- tx coming from `decodeTx` doesn't contain previous tx outputs that - -- correspond to this tx inputs, so its inputs aren't "resolved". - -- We restore corresponding outputs by searching them in the UTxO again. - let txResolved = tx - { resolvedInputs = - resolveInputs (resolvedInputs tx) - , resolvedCollateralInputs = - resolveInputs (resolvedCollateralInputs tx) - } - resolveInputs = fmap (\(txIn, _) -> - (txIn, UTxO.lookup txIn (wallet ^. #utxo))) + timeTranslation utxoIndex rootKey passphraseScheme userPassphrase + pp txLayer changeAddrGen preSelection txCtx = do + wallet <- get + (unsignedBalancedTx, updatedWalletState) <- lift $ + buildTransactionPure @s @era + wallet timeTranslation utxoIndex txLayer changeAddrGen pp preSelection txCtx + put wallet { getState = updatedWalletState } + + let mExternalRewardAccount = case view #txWithdrawal txCtx of + WithdrawalExternal _ _ _ externalXPrv + -> Just (externalXPrv, mempty) -- no passphrase + _ + -> Nothing + + let passphrase = preparePassphrase passphraseScheme userPassphrase + signedTx = signTransaction @k @'CredFromKeyK + (keyFlavorFromState @s) + txLayer + anyCardanoEra + AnyWitnessCountCtx + (isOwned (getState wallet) (rootKey, passphrase)) + mExternalRewardAccount + (rootKey, passphrase) + (wallet ^. #utxo) + Nothing + (sealedTxFromCardano $ inAnyCardanoEra unsignedBalancedTx) + + let ( tx + , _tokenMapWithScripts1 + , _tokenMapWithScripts2 + , _certificates + , _validityIntervalExplicit + , _witnessCount + ) = decodeTx txLayer anyCardanoEra AnyWitnessCountCtx signedTx + + let utxo' = applyOurTxToUTxO + (Slot.at $ currentTip wallet ^. #slotNo) + (currentTip wallet ^. #blockHeight) + (getState wallet) + tx + (wallet ^. #utxo) + meta = case utxo' of + Nothing -> error $ unwords + [ "buildAndSignTransactionPure:" + , "Can't apply constructed transaction." + ] + Just ((_tx, appliedMeta), _deltaUtxo, _nextUtxo) -> + appliedMeta + { status = Pending + , expiry = Just (snd (txValidityInterval txCtx)) + } - pure BuiltTx - { builtTx = txResolved - , builtTxMeta = meta - , builtSealedTx = signedTx + -- tx coming from `decodeTx` doesn't contain previous tx outputs that + -- correspond to this tx inputs, so its inputs aren't "resolved". + -- We restore corresponding outputs by searching them in the UTxO again. + let txResolved = tx + { resolvedInputs = + resolveInputs (resolvedInputs tx) + , resolvedCollateralInputs = + resolveInputs (resolvedCollateralInputs tx) } + resolveInputs = fmap (\(txIn, _) -> + (txIn, UTxO.lookup txIn (wallet ^. #utxo))) + + pure BuiltTx + { builtTx = txResolved + , builtTxMeta = meta + , builtSealedTx = signedTx + } where - anyCardanoEra = Write.toAnyCardanoEra era + anyCardanoEra = Cardano.AnyCardanoEra $ Write.cardanoEra @era buildTransaction :: forall s era. @@ -2090,7 +2102,7 @@ buildTransaction -> TransactionLayer (KeyOf s) 'CredFromKeyK SealedTx -> TimeTranslation -> ChangeAddressGen s - -> ProtocolParameters + -> Write.ProtocolParameters era -> TransactionCtx -> [TxOut] -- ^ payment outputs -> IO (Cardano.Tx era, Wallet s) @@ -2113,7 +2125,7 @@ buildTransaction DBLayer{..} txLayer timeTranslation changeAddrGen utxo txLayer changeAddrGen - (Write.unsafeFromWalletProtocolParameters protocolParameters) + protocolParameters PreSelection { outputs = paymentOuts } txCtx & runExceptT . withExceptT @@ -2187,24 +2199,6 @@ unsafeShelleyOnlyGetRewardXPub walletState = , "can't delegate using non-shelley wallet" ] --- TODO: ADP-2459 - replace with something nicer. -toBalanceTxPParams - :: forall era. Write.IsRecentEra era - => ProtocolParameters - -> (ProtocolParameters, Cardano.BundledProtocolParameters era) -toBalanceTxPParams pp = - ( pp - , maybe - (error $ unwords - [ "toBalanceTxPParams: no nodePParams." - , "This should only be possible in Byron, where withRecentEra" - , "should prevent this from being reached." - ]) - (Cardano.bundleProtocolParams - (Write.fromRecentEra (Write.recentEra @era))) - $ currentNodeProtocolParameters pp - ) - -- | Produce witnesses and construct a transaction from a given selection. -- -- Requires the encryption passphrase in order to decrypt the root private key. @@ -2745,6 +2739,14 @@ data DelegationFee = DelegationFee instance NFData DelegationFee +getStakeKeyDeposit + :: forall era. Write.IsRecentEra era + => Write.ProtocolParameters era + -> Coin +getStakeKeyDeposit = toWallet + . Write.stakeKeyDeposit (recentEra @era) + . Write.pparamsLedger + delegationFee :: forall s . ( AddressBookIso s @@ -2754,29 +2756,25 @@ delegationFee => DBLayer IO s -> NetworkLayer IO Read.Block -> TransactionLayer (KeyOf s) 'CredFromKeyK SealedTx - -> TimeTranslation - -> AnyRecentEra -> ChangeAddressGen s -> IO DelegationFee -delegationFee db@DBLayer{..} netLayer txLayer timeTranslation era - changeAddressGen = - Write.withRecentEra era $ \(recentEra :: Write.RecentEra era) -> do - protocolParams <- Write.unsafeFromWalletProtocolParameters - <$> liftIO (currentProtocolParameters netLayer) - feePercentiles <- transactionFee @s - db protocolParams txLayer timeTranslation recentEra changeAddressGen - defaultTransactionCtx - -- It would seem that we should add a delegation action - -- to the partial tx we construct, this was not done - -- previously, and the difference should be negligible. - (PreSelection []) - deposit <- liftIO - $ atomically isStakeKeyRegistered <&> \case - False -> toWallet - $ Write.stakeKeyDeposit recentEra - $ Write.pparamsLedger protocolParams - True -> Coin 0 - pure DelegationFee { feePercentiles, deposit } +delegationFee db@DBLayer{..} netLayer txLayer changeAddressGen = do + (Write.InAnyRecentEra era protocolParams, timeTranslation) + <- readNodeTipStateForTxWrite netLayer + feePercentiles <- transactionFee @s + db protocolParams txLayer timeTranslation changeAddressGen + defaultTransactionCtx + -- It would seem that we should add a delegation action + -- to the partial tx we construct, this was not done + -- previously, and the difference should be negligible. + (PreSelection []) + deposit <- liftIO + $ atomically isStakeKeyRegistered <&> \case + False -> toWallet + $ Write.stakeKeyDeposit era + $ Write.pparamsLedger protocolParams + True -> Coin 0 + pure DelegationFee { feePercentiles, deposit } transactionFee :: forall s era @@ -2789,13 +2787,12 @@ transactionFee -> Write.ProtocolParameters era -> TransactionLayer (KeyOf s) 'CredFromKeyK SealedTx -> TimeTranslation - -> Write.RecentEra era -> ChangeAddressGen s -> TransactionCtx -> PreSelection -> IO (Percentile 10 Fee, Percentile 90 Fee) transactionFee DBLayer{atomically, walletState} protocolParams txLayer - timeTranslation recentEra changeAddressGen txCtx preSelection = do + timeTranslation changeAddressGen txCtx preSelection = do wallet <- liftIO . atomically $ readDBVar walletState <&> WalletState.getLatest utxoIndex <- @@ -2843,7 +2840,7 @@ transactionFee DBLayer{atomically, walletState} protocolParams txLayer Cardano.TxFeeExplicit _ coin -> Fee (fromCardanoLovelace coin) Cardano.TxFeeImplicit Cardano.TxFeesImplicitInByronEra - -> case recentEra of {} + -> case Write.recentEra @era of {} Left (ErrBalanceTxSelectAssets errSelectAssets) -> throwE errSelectAssets Left otherErr -> throwIO $ ExceptionBalanceTx otherErr @@ -2926,13 +2923,13 @@ calculateFeePercentiles -- computes the superinterval `(p - x, q + x)`, where `x` is the cost of -- encoding `n` bytes according to the given protocol parameters. padFeePercentiles - :: ProtocolParameters + :: Write.FeePerByte -> Quantity "byte" Word -- ^ Number of bytes by which to extend the interval in both directions. -> (Percentile 10 Fee, Percentile 90 Fee) -> (Percentile 10 Fee, Percentile 90 Fee) padFeePercentiles - pp + feePerByte (Quantity byteDelta) (Percentile (Fee a), Percentile (Fee b)) = ( Percentile $ Fee $ a `Coin.difference` coinDelta @@ -2941,10 +2938,7 @@ padFeePercentiles where coinDelta :: Coin coinDelta = - Coin.fromNatural . ceiling @Double @Natural $ - fromIntegral @Word @Double byteDelta * slope feeFunction - - LinearFee feeFunction = pp ^. #txParameters . #getFeePolicy + toWallet $ Write.feeOfBytes feePerByte (intCast byteDelta) {------------------------------------------------------------------------------- Key Store diff --git a/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs index cb2a7433c79..ad6cad7e9d1 100644 --- a/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs +++ b/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs @@ -93,7 +93,6 @@ import Ouroboros.Consensus.HardFork.History.Summary import Ouroboros.Network.Block ( BlockNo (..), ChainHash, SlotNo (..) ) -import qualified Cardano.Api.Shelley as Node import qualified Cardano.Chain.Update as Update import qualified Cardano.Chain.Update.Validation.Interface as Update import qualified Cardano.Crypto.Hashing as CC @@ -106,6 +105,7 @@ import qualified Cardano.Wallet.Primitive.Types.Tx as W import qualified Cardano.Wallet.Primitive.Types.Tx.Constraints as W import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W ( TxOut (TxOut) ) +import qualified Cardano.Wallet.Write.Tx as Write import qualified Data.Map.Strict as Map import qualified Ouroboros.Consensus.Block as O @@ -151,7 +151,7 @@ mainnetNetworkParameters = W.NetworkParameters , maximumCollateralInputCount = 0 , minimumCollateralPercentage = 0 , executionUnitPrices = Nothing - , currentNodeProtocolParameters = Nothing + , currentLedgerProtocolParameters = Write.InNonRecentEraByron } } @@ -314,10 +314,9 @@ fromMaxSize = protocolParametersFromPP :: W.EraInfo Bound - -> Maybe Node.ProtocolParameters -> Update.ProtocolParameters -> W.ProtocolParameters -protocolParametersFromPP eraInfo currentNodeProtocolParameters pp = +protocolParametersFromPP eraInfo pp = W.ProtocolParameters { decentralizationLevel = minBound , txParameters = W.TxParameters @@ -334,7 +333,7 @@ protocolParametersFromPP eraInfo currentNodeProtocolParameters pp = , maximumCollateralInputCount = 0 , minimumCollateralPercentage = 0 , executionUnitPrices = Nothing - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = Write.InNonRecentEraByron } where fromBound (Bound _relTime _slotNo (O.EpochNo e)) = @@ -344,11 +343,10 @@ protocolParametersFromPP eraInfo currentNodeProtocolParameters pp = -- cardano-chain update state record. protocolParametersFromUpdateState :: W.EraInfo Bound - -> Maybe Node.ProtocolParameters -> Update.State -> W.ProtocolParameters -protocolParametersFromUpdateState b ppNode = - (protocolParametersFromPP b ppNode) . Update.adoptedProtocolParameters +protocolParametersFromUpdateState b = + (protocolParametersFromPP b) . Update.adoptedProtocolParameters -- | Convert non AVVM balances to genesis UTxO. fromNonAvvmBalances :: GenesisNonAvvmBalances -> [W.TxOut] @@ -375,7 +373,7 @@ fromGenesisData (genesisData, genesisHash) = } , protocolParameters = -- emptyEraInfo contains no info about byron. Should we add it? - protocolParametersFromPP W.emptyEraInfo Nothing $ + protocolParametersFromPP W.emptyEraInfo $ gdProtocolParameters genesisData } , fromNonAvvmBalances . gdNonAvvmBalances $ genesisData diff --git a/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs b/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs index 59073335655..e03141bacb3 100644 --- a/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs @@ -175,6 +175,8 @@ import Cardano.Wallet.Primitive.Types.Tx.Tx ( Tx (..) ) import Cardano.Wallet.Util ( ShowFmt (..), parseURI, uriToText ) +import Cardano.Wallet.Write.Tx + ( MaybeInRecentEra ) import Control.Arrow ( left, right ) import Control.DeepSeq @@ -256,7 +258,7 @@ import Numeric.Natural import Test.QuickCheck ( Arbitrary (..), oneof ) -import qualified Cardano.Api.Shelley as Node +import qualified Cardano.Wallet.Write.ProtocolParameters as Write import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -883,10 +885,10 @@ data ProtocolParameters = ProtocolParameters -- used to determine the fee for the use of a script within a -- transaction, based on the 'ExecutionUnits' needed by the use of -- the script. - , currentNodeProtocolParameters - :: Maybe Node.ProtocolParameters - -- ^ Get the last known node's protocol parameters. - -- In principle, these can only change once per epoch. + , currentLedgerProtocolParameters + :: MaybeInRecentEra Write.ProtocolParameters + -- ^ The full, raw ledger protocol parameters for writing (constructing) + -- transactions in case the node is in a recent era. } deriving (Eq, Generic, Show) instance NFData ProtocolParameters where @@ -900,7 +902,7 @@ instance NFData ProtocolParameters where , rnf maximumCollateralInputCount , rnf minimumCollateralPercentage , rnf executionUnitPrices - -- currentNodeProtocolParameters is omitted + -- currentLedgerProtocolParameters is omitted ] instance Buildable ProtocolParameters where diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs index ad2318b1ce7..7012d74ed40 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -416,6 +416,8 @@ import qualified Cardano.Wallet.Primitive.Types.Tx.TxIn as W import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W ( TxOut (TxOut) ) import qualified Cardano.Wallet.Primitive.Types.UTxO as W +import qualified Cardano.Wallet.Write.ProtocolParameters as Write +import qualified Cardano.Wallet.Write.Tx as Write import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.Binary.Bech32.TH as Bech32 import qualified Codec.CBOR.Decoding as CBOR @@ -872,10 +874,9 @@ fromMaxSize = Quantity . fromIntegral fromShelleyPParams :: W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Shelley.ShelleyPParams StandardShelley -> W.ProtocolParameters -fromShelleyPParams eraInfo currentNodeProtocolParameters pp = +fromShelleyPParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -892,15 +893,15 @@ fromShelleyPParams eraInfo currentNodeProtocolParameters pp = , maximumCollateralInputCount = 0 , minimumCollateralPercentage = 0 , executionUnitPrices = Nothing - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = Write.InNonRecentEraShelley + } fromAllegraPParams :: W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Shelley.ShelleyPParams StandardAllegra -> W.ProtocolParameters -fromAllegraPParams eraInfo currentNodeProtocolParameters pp = +fromAllegraPParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -917,15 +918,14 @@ fromAllegraPParams eraInfo currentNodeProtocolParameters pp = , maximumCollateralInputCount = 0 , minimumCollateralPercentage = 0 , executionUnitPrices = Nothing - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = Write.InNonRecentEraAllegra } fromMaryPParams :: W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Mary.ShelleyPParams StandardMary -> W.ProtocolParameters -fromMaryPParams eraInfo currentNodeProtocolParameters pp = +fromMaryPParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -942,7 +942,7 @@ fromMaryPParams eraInfo currentNodeProtocolParameters pp = , maximumCollateralInputCount = 0 , minimumCollateralPercentage = 0 , executionUnitPrices = Nothing - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = Write.InNonRecentEraMary } fromBoundToEpochNo :: Bound -> W.EpochNo @@ -952,10 +952,9 @@ fromBoundToEpochNo (Bound _relTime _slotNo (EpochNo e)) = fromAlonzoPParams :: HasCallStack => W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Alonzo.AlonzoPParams StandardAlonzo -> W.ProtocolParameters -fromAlonzoPParams eraInfo currentNodeProtocolParameters pp = +fromAlonzoPParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -975,16 +974,15 @@ fromAlonzoPParams eraInfo currentNodeProtocolParameters pp = Alonzo._collateralPercentage pp , executionUnitPrices = Just $ executionUnitPricesFromPParams pp - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = Write.InNonRecentEraAlonzo } fromBabbagePParams :: HasCallStack => W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Babbage.BabbagePParams StandardBabbage -> W.ProtocolParameters -fromBabbagePParams eraInfo currentNodeProtocolParameters pp = +fromBabbagePParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -1004,16 +1002,16 @@ fromBabbagePParams eraInfo currentNodeProtocolParameters pp = Babbage._collateralPercentage pp , executionUnitPrices = Just $ executionUnitPricesFromPParams pp - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = + Write.InRecentEraBabbage $ Write.ProtocolParameters pp } fromConwayPParams :: HasCallStack => W.EraInfo Bound - -> Maybe Cardano.ProtocolParameters -> Babbage.BabbagePParams StandardConway -> W.ProtocolParameters -fromConwayPParams eraInfo currentNodeProtocolParameters pp = +fromConwayPParams eraInfo pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp , txParameters = txParametersFromPParams @@ -1028,7 +1026,8 @@ fromConwayPParams eraInfo currentNodeProtocolParameters pp = unsafeIntToWord $ Conway._maxCollateralInputs pp , minimumCollateralPercentage = Conway._collateralPercentage pp , executionUnitPrices = Just $ executionUnitPricesFromPParams pp - , currentNodeProtocolParameters + , currentLedgerProtocolParameters = + Write.InRecentEraConway $ Write.ProtocolParameters pp } -- | Extract the current network decentralization level from the given set of @@ -1154,7 +1153,7 @@ fromGenesisData g = } , slottingParameters = slottingParametersFromGenesis g , protocolParameters = - fromShelleyPParams W.emptyEraInfo Nothing $ sgProtocolParams g + fromShelleyPParams W.emptyEraInfo $ sgProtocolParams g } , genesisBlockFromTxOuts (ListMap.toList $ sgInitialFunds g) , poolCerts $ sgStaking g diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs index 82067117afa..7d9c796d7f8 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs @@ -279,7 +279,6 @@ import UnliftIO.Concurrent import UnliftIO.Exception ( Handler (..), IOException ) -import qualified Cardano.Api as Cardano import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import qualified Cardano.Ledger.Babbage.PParams as Babbage @@ -710,35 +709,20 @@ mkWalletToNodeProtocols ((slottingParametersFromGenesis . getCompactGenesis) <$> LSQry Shelley.GetGenesisConfig) - ppNode <- onAnyEra - (pure Nothing) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraShelley - <$> LSQry Shelley.GetCurrentPParams) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraAllegra - <$> LSQry Shelley.GetCurrentPParams) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraMary - <$> LSQry Shelley.GetCurrentPParams) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraAlonzo - <$> LSQry Shelley.GetCurrentPParams) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraBabbage - <$> LSQry Shelley.GetCurrentPParams) - (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraConway - <$> LSQry Shelley.GetCurrentPParams) - pp <- onAnyEra - (protocolParametersFromUpdateState eraBounds ppNode + (protocolParametersFromUpdateState eraBounds <$> LSQry Byron.GetUpdateInterfaceState) - (fromShelleyPParams eraBounds ppNode + (fromShelleyPParams eraBounds <$> LSQry Shelley.GetCurrentPParams) - (fromAllegraPParams eraBounds ppNode + (fromAllegraPParams eraBounds <$> LSQry Shelley.GetCurrentPParams) - (fromMaryPParams eraBounds ppNode + (fromMaryPParams eraBounds <$> LSQry Shelley.GetCurrentPParams) - (fromAlonzoPParams eraBounds ppNode + (fromAlonzoPParams eraBounds <$> LSQry Shelley.GetCurrentPParams) - (fromBabbagePParams eraBounds ppNode + (fromBabbagePParams eraBounds <$> LSQry Shelley.GetCurrentPParams) - (fromConwayPParams eraBounds ppNode + (fromConwayPParams eraBounds <$> LSQry Shelley.GetCurrentPParams) return (pp, sp) diff --git a/lib/wallet/src/Cardano/Wallet/Write/ProtocolParameters.hs b/lib/wallet/src/Cardano/Wallet/Write/ProtocolParameters.hs index 90b19e527e7..64ee7f5b989 100644 --- a/lib/wallet/src/Cardano/Wallet/Write/ProtocolParameters.hs +++ b/lib/wallet/src/Cardano/Wallet/Write/ProtocolParameters.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Copyright: © 2023 IOHK @@ -9,14 +11,10 @@ -- module Cardano.Wallet.Write.ProtocolParameters ( ProtocolParameters (..) - , unsafeFromWalletProtocolParameters ) where import Prelude -import qualified Cardano.Api as CardanoApi -import qualified Cardano.Api.Extra as CardanoApi -import qualified Cardano.Wallet.Primitive.Types as Wallet import qualified Cardano.Wallet.Write.Tx as Write -- TODO: @@ -27,24 +25,6 @@ newtype ProtocolParameters era = ProtocolParameters :: Write.PParams (Write.ShelleyLedgerEra era) } --- TODO: ADP-2459 - replace with something nicer. -unsafeFromWalletProtocolParameters - :: forall era. CardanoApi.IsShelleyBasedEra era - => Wallet.ProtocolParameters - -> ProtocolParameters era -unsafeFromWalletProtocolParameters pparamsWallet = ProtocolParameters $ - maybe - (error missingNodeParamsError) - unbundleParameters - (Wallet.currentNodeProtocolParameters pparamsWallet) - where - unbundleParameters - = CardanoApi.unbundleLedgerShelleyBasedProtocolParams - (CardanoApi.shelleyBasedEra @era) - . CardanoApi.bundleProtocolParams - (CardanoApi.cardanoEra @era) - missingNodeParamsError = unwords - [ "unsafeFromWalletProtocolParameters: no nodePParams." - , "This should only be possible in Byron, where IsShelleyBasedEra" - , "should prevent this from being reached." - ] +deriving instance Eq (Write.PParams (Write.ShelleyLedgerEra era)) => Eq (ProtocolParameters era) +deriving instance Show (Write.PParams (Write.ShelleyLedgerEra era)) => Show (ProtocolParameters era) + diff --git a/lib/wallet/src/Cardano/Wallet/Write/Tx.hs b/lib/wallet/src/Cardano/Wallet/Write/Tx.hs index 2f0bb7125d3..5f58be6e60d 100644 --- a/lib/wallet/src/Cardano/Wallet/Write/Tx.hs +++ b/lib/wallet/src/Cardano/Wallet/Write/Tx.hs @@ -9,10 +9,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Copyright: © 2022 IOHK @@ -34,6 +36,8 @@ module Cardano.Wallet.Write.Tx , IsRecentEra (..) , toRecentEra , fromRecentEra + , MaybeInRecentEra (..) + , toRecentEraGADT , LatestLedgerEra , LatestEra , withConstraints @@ -196,6 +200,7 @@ import Data.Generics.Internal.VL.Lens ( (^.) ) import Data.Generics.Labels () +import Data.Kind (Type) import Data.Generics.Product ( HasField' ) import Data.IntCast @@ -352,6 +357,32 @@ cardanoEra = cardanoEraFromRecentEra $ recentEra @era shelleyBasedEra :: forall era. IsRecentEra era => Cardano.ShelleyBasedEra era shelleyBasedEra = shelleyBasedEraFromRecentEra $ recentEra @era +data MaybeInRecentEra (thing :: Type -> Type) + = InNonRecentEraByron + | InNonRecentEraShelley + | InNonRecentEraAllegra + | InNonRecentEraMary + | InNonRecentEraAlonzo + | InRecentEraBabbage (thing BabbageEra) + | InRecentEraConway (thing ConwayEra) + +deriving instance (Eq (a BabbageEra), (Eq (a ConwayEra))) + => Eq (MaybeInRecentEra a) +deriving instance (Show (a BabbageEra), (Show (a ConwayEra))) + => Show (MaybeInRecentEra a) + +toRecentEraGADT + :: MaybeInRecentEra a + -> Either Cardano.AnyCardanoEra (InAnyRecentEra a) +toRecentEraGADT = \case + InNonRecentEraByron -> Left $ Cardano.AnyCardanoEra Cardano.ByronEra + InNonRecentEraShelley -> Left $ Cardano.AnyCardanoEra Cardano.ShelleyEra + InNonRecentEraAllegra -> Left $ Cardano.AnyCardanoEra Cardano.AllegraEra + InNonRecentEraMary -> Left $ Cardano.AnyCardanoEra Cardano.MaryEra + InNonRecentEraAlonzo -> Left $ Cardano.AnyCardanoEra Cardano.AlonzoEra + InRecentEraBabbage a -> Right $ InAnyRecentEra recentEra a + InRecentEraConway a -> Right $ InAnyRecentEra recentEra a + data InAnyRecentEra thing where InAnyRecentEra :: IsRecentEra era -- Provide class constraint diff --git a/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs b/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs index a129b1690d9..35bbd685e3a 100644 --- a/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs +++ b/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs @@ -75,6 +75,8 @@ import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) import qualified Cardano.Api.Shelley as C +import qualified Cardano.Wallet.Write.ProtocolParameters as Write +import qualified Cardano.Wallet.Write.Tx as Write import qualified Data.ByteString.Char8 as B8 {----------------------------------------------------------------------------- @@ -145,7 +147,10 @@ dummyProtocolParameters = ProtocolParameters { pricePerStep = 7.21e-5 , pricePerMemoryUnit = 0.0577 } - , currentNodeProtocolParameters = Just dummyNodeProtocolParameters + , currentLedgerProtocolParameters = + Write.InRecentEraBabbage + $ Write.ProtocolParameters + $ C.toLedgerPParams C.ShelleyBasedEraBabbage dummyNodeProtocolParameters } -- | Dummy parameters that are consistent with the @dummy*@ parameters. diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs index 8f519def508..dfe99c91b06 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs @@ -228,8 +228,12 @@ import qualified Cardano.Wallet.Address.Derivation.Shared as Shared import qualified Cardano.Wallet.Address.Derivation.Shelley as Shelley import qualified Cardano.Wallet.Address.Discovery.Sequential as Seq import qualified Cardano.Wallet.Address.Discovery.Shared as Shared +<<<<<<< HEAD import Cardano.Wallet.Address.Keys.WalletKey ( getRawKey, liftRawKey, publicKey ) +======= +import qualified Cardano.Wallet.Write.Tx as Write +>>>>>>> 02855b3fb1 (Completely drop Cardano.ProtocolParameters) import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 @@ -723,7 +727,7 @@ instance Arbitrary ProtocolParameters where <*> genMaximumCollateralInputCount <*> genMinimumCollateralPercentage <*> arbitrary - <*> pure Nothing + <*> pure Write.InNonRecentEraAlonzo where genMaximumCollateralInputCount :: Gen Word16 genMaximumCollateralInputCount = arbitrarySizedNatural diff --git a/lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs index 43f3eee930f..252c201f79b 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs @@ -1999,8 +1999,8 @@ dummyProtocolParameters = ProtocolParameters error "dummyProtocolParameters: minimumCollateralPercentage" , executionUnitPrices = error "dummyProtocolParameters: executionUnitPrices" - , currentNodeProtocolParameters = - error "dummyProtocolParameters: currentNodeProtocolParameters" + , currentLedgerProtocolParameters = + error "dummyProtocolParameters: currentLedgerProtocolParameters" } --------------------------------------------------------------------------------