From 4f2d9fb76222596c58129d7d52a8dad477d8e8a9 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 25 Oct 2022 18:50:26 +0200 Subject: [PATCH 01/30] rename Cardano.Wallet.Shelley.Pools to Cardano.Wallet.Pools --- lib/wallet/api/http/Cardano/Wallet/Api.hs | 4 ++-- lib/wallet/api/http/Cardano/Wallet/Api/Client.hs | 4 ++-- .../api/http/Cardano/Wallet/Api/Http/Server.hs | 4 ++-- .../http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 4 ++-- lib/wallet/api/http/Cardano/Wallet/Api/Types.hs | 4 ++-- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 12 ++++++------ lib/wallet/api/http/Cardano/Wallet/Tracers.hs | 4 ++-- lib/wallet/bench/latency-bench.hs | 4 ++-- lib/wallet/cardano-wallet.cabal | 2 +- .../src/Test/Integration/Framework/DSL.hs | 4 ++-- .../src/Test/Integration/Scenario/API/Network.hs | 4 ++-- .../Test/Integration/Scenario/API/Shelley/Network.hs | 4 ++-- .../Integration/Scenario/API/Shelley/Settings.hs | 4 ++-- .../Integration/Scenario/API/Shelley/StakePools.hs | 4 ++-- .../Scenario/API/Shelley/TransactionsNew.hs | 4 ++-- lib/wallet/src/Cardano/Wallet/{Shelley => }/Pools.hs | 2 +- lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs | 12 ++++++------ 17 files changed, 40 insertions(+), 40 deletions(-) rename lib/wallet/src/Cardano/Wallet/{Shelley => }/Pools.hs (99%) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api.hs b/lib/wallet/api/http/Cardano/Wallet/Api.hs index 485cc2628c1..3e7489ce7d0 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api.hs @@ -242,6 +242,8 @@ import Cardano.Wallet.DB ( DBFactory, DBLayer ) import Cardano.Wallet.Network ( NetworkLayer ) +import Cardano.Wallet.Pools + ( StakePool ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth, DerivationIndex, Role ) import Cardano.Wallet.Primitive.Types @@ -308,8 +310,6 @@ import Servant.API.Verbs ) import qualified Cardano.Wallet.Primitive.Types as W -import Cardano.Wallet.Shelley.Pools - ( StakePool ) type ApiV2 n = "v2" :> Api n diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs index b8ea61eeda0..c619e4aefdb 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Client.hs @@ -97,6 +97,8 @@ import Cardano.Wallet.Api.Types ) import Cardano.Wallet.Api.Types.SchemaMetadata ( TxMetadataSchema, toSimpleMetadataFlag ) +import Cardano.Wallet.Pools + ( StakePool ) import Cardano.Wallet.Primitive.Types ( SortOrder, WalletId ) import Cardano.Wallet.Primitive.Types.Address @@ -122,8 +124,6 @@ import Servant.Client import UnliftIO.Exception ( throwString ) -import Cardano.Wallet.Shelley.Pools - ( StakePool ) import qualified Data.Aeson as Aeson {------------------------------------------------------------------------------- diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs index b0c620535a7..2b969fe3299 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs @@ -169,6 +169,8 @@ import Cardano.Wallet.Api.Types.Error ( ApiErrorInfo (..) ) import Cardano.Wallet.Api.Types.SchemaMetadata ( TxMetadataSchema (..), parseSimpleMetadataFlag ) +import Cardano.Wallet.Pools + ( StakePoolLayer (..) ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..), Depth (..), PaymentAddress (..), Role (..) ) import Cardano.Wallet.Primitive.AddressDerivation.Byron @@ -195,8 +197,6 @@ import Cardano.Wallet.Shelley.Compatibility ( inspectAddress, rewardAccountFromAddress ) import Cardano.Wallet.Shelley.Network.Discriminant ( HasNetworkId (networkIdVal) ) -import Cardano.Wallet.Shelley.Pools - ( StakePoolLayer (..) ) import Control.Applicative ( liftA2 ) import Control.Monad 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 d403e99c684..7a063c991d2 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 @@ -338,6 +338,8 @@ import Cardano.Wallet.DB ( DBFactory (..) ) import Cardano.Wallet.Network ( NetworkLayer (..), fetchRewardAccountBalances, timeInterpreter ) +import Cardano.Wallet.Pools + ( EpochInfo (..), toEpochInfo ) import Cardano.Wallet.Primitive.AddressDerivation ( BoundedAddressLength (..) , DelegationAddress (..) @@ -491,8 +493,6 @@ import Cardano.Wallet.Registry ) import Cardano.Wallet.Shelley.Compatibility.Ledger ( toLedger ) -import Cardano.Wallet.Shelley.Pools - ( EpochInfo (..), toEpochInfo ) import Cardano.Wallet.TokenMetadata ( TokenMetadataClient, fillMetadata ) import Cardano.Wallet.Transaction diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs index 4c79d9ea325..19d966ab648 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Types.hs @@ -334,6 +334,8 @@ import Cardano.Wallet.Api.Types.Transaction , ApiWithdrawalGeneral (..) , ResourceContext (..) ) +import Cardano.Wallet.Pools + ( EpochInfo, StakePool (..), StakePoolFlag, StakePoolMetrics ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (..), DerivationIndex (..), Index (..), NetworkDiscriminant (..) ) import Cardano.Wallet.Primitive.AddressDiscovery.Random @@ -386,8 +388,6 @@ import Cardano.Wallet.Shelley.Network.Discriminant , EncodeAddress (..) , EncodeStakeAddress (..) ) -import Cardano.Wallet.Shelley.Pools - ( EpochInfo, StakePool (..), StakePoolFlag, StakePoolMetrics ) import Cardano.Wallet.TokenMetadata ( TokenMetadataError (..) ) import Cardano.Wallet.Util diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 963ca34296f..5452e736346 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -43,6 +43,12 @@ import Cardano.Wallet.DB.Store.Checkpoints ( PersistAddressBook ) import Cardano.Wallet.Network ( NetworkLayer (..) ) +import Cardano.Wallet.Pools + ( StakePoolLayer (..) + , withBlockfrostStakePoolLayer + , withNodeStakePoolLayer + , withStakePoolDbLayer + ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..) , Depth (..) @@ -107,12 +113,6 @@ import Cardano.Wallet.Shelley.Network.Discriminant , discriminantNetwork , networkDiscriminantToId ) -import Cardano.Wallet.Shelley.Pools - ( StakePoolLayer (..) - , withBlockfrostStakePoolLayer - , withNodeStakePoolLayer - , withStakePoolDbLayer - ) import Cardano.Wallet.Shelley.Transaction ( newTransactionLayer ) import Cardano.Wallet.TokenMetadata diff --git a/lib/wallet/api/http/Cardano/Wallet/Tracers.hs b/lib/wallet/api/http/Cardano/Wallet/Tracers.hs index 0a828a9fb94..67e9ae5d8c5 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Tracers.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Tracers.hs @@ -35,10 +35,10 @@ import Cardano.Wallet.DB.Layer ( DBFactoryLog ) import Cardano.Wallet.Logging ( trMessageText ) +import Cardano.Wallet.Pools + ( StakePoolLog ) import Cardano.Wallet.Shelley.Network ( NetworkLayerLog ) -import Cardano.Wallet.Shelley.Pools - ( StakePoolLog ) import Cardano.Wallet.TokenMetadata ( TokenMetadataLog ) import Control.Applicative diff --git a/lib/wallet/bench/latency-bench.hs b/lib/wallet/bench/latency-bench.hs index fc932bf2199..ec6c5501862 100644 --- a/lib/wallet/bench/latency-bench.hs +++ b/lib/wallet/bench/latency-bench.hs @@ -58,6 +58,8 @@ import Cardano.Wallet.Logging ( trMessage ) import Cardano.Wallet.Network.Ports ( portFromURL ) +import Cardano.Wallet.Pools + ( StakePool ) import Cardano.Wallet.Primitive.AddressDerivation ( NetworkDiscriminant (..) ) import Cardano.Wallet.Primitive.SyncProgress @@ -75,8 +77,6 @@ import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Faucet ( initFaucet ) -import Cardano.Wallet.Shelley.Pools - ( StakePool ) import Cardano.Wallet.Unsafe ( unsafeFromText ) import Control.Monad diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index 27661ec7df0..d77cf7061f1 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -252,6 +252,7 @@ library Cardano.Wallet.Network.Light Cardano.Wallet.Network.Ports Cardano.Wallet.Orphans + Cardano.Wallet.Pools Cardano.Wallet.Primitive.AddressDerivation Cardano.Wallet.Primitive.AddressDerivation.Byron Cardano.Wallet.Primitive.AddressDerivation.Icarus @@ -362,7 +363,6 @@ library Cardano.Wallet.Shelley.Network.Blockfrost.Monad Cardano.Wallet.Shelley.Network.Discriminant Cardano.Wallet.Shelley.Network.Node - Cardano.Wallet.Shelley.Pools Cardano.Wallet.Shelley.Transaction Cardano.Wallet.TokenMetadata Cardano.Wallet.Transaction diff --git a/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs b/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs index 78bc3f0c4d9..7ec3e4d67fd 100644 --- a/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs +++ b/lib/wallet/integration/src/Test/Integration/Framework/DSL.hs @@ -283,6 +283,8 @@ import Cardano.Wallet.Api.Types.SchemaMetadata ( TxMetadataSchema, toSimpleMetadataFlag ) import Cardano.Wallet.Compat ( (^?) ) +import Cardano.Wallet.Pools + ( EpochInfo, StakePool ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (..) , DerivationIndex (..) @@ -342,8 +344,6 @@ import Cardano.Wallet.Primitive.Types.UTxO , computeUtxoStatistics , log10 ) -import Cardano.Wallet.Shelley.Pools - ( EpochInfo, StakePool ) import Control.Arrow ( second ) import Control.Monad diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs index cf7b1edcad1..a570ec50267 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Network.hs @@ -18,6 +18,8 @@ import Cardano.Wallet.Api.Types , WalletStyle (..) , nextEpoch ) +import Cardano.Wallet.Pools + ( EpochInfo (..) ) import Cardano.Wallet.Primitive.SyncProgress ( SyncProgress (..) ) import Cardano.Wallet.Primitive.Types.ProtocolMagic @@ -55,8 +57,6 @@ import Test.Utils.Paths ( inNixBuild ) import qualified Cardano.Wallet.Api.Link as Link -import Cardano.Wallet.Shelley.Pools - ( EpochInfo (..) ) import qualified Network.HTTP.Types.Status as HTTP spec :: SpecWith Context diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs index 236c8a4c1fb..587d5162c29 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Network.hs @@ -12,10 +12,10 @@ import Prelude import Cardano.Wallet.Api.Types ( ApiEra (..), ApiNetworkParameters (..) ) +import Cardano.Wallet.Pools + ( EpochInfo (..) ) import Cardano.Wallet.Primitive.Types ( ExecutionUnitPrices (..) ) -import Cardano.Wallet.Shelley.Pools - ( EpochInfo (..) ) import Data.List ( (\\) ) import Data.Quantity diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs index a3b501fa9ce..78aae3cd2d9 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/Settings.hs @@ -15,12 +15,12 @@ import Prelude import Cardano.Wallet.Api.Lib.ApiT ( ApiT (..) ) +import Cardano.Wallet.Pools + ( StakePool ) import Cardano.Wallet.Primitive.Types ( PoolMetadataSource (..), Settings ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) -import Cardano.Wallet.Shelley.Pools - ( StakePool ) import Data.Either ( fromRight ) import Data.Generics.Internal.VL.Lens diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs index 06afeee362f..c35f74dcb91 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -36,6 +36,8 @@ import Cardano.Wallet.Api.Types , ApiWithdrawal (..) , WalletStyle (..) ) +import Cardano.Wallet.Pools + ( StakePool (..), StakePoolFlag (Delisted) ) import Cardano.Wallet.Primitive.Types ( FeePolicy (..), LinearFunction (..), PoolMetadataSource (..) ) import Cardano.Wallet.Primitive.Types.Coin @@ -44,8 +46,6 @@ import Cardano.Wallet.Primitive.Types.Tx.TxMeta ( Direction (..), TxStatus (..) ) import Cardano.Wallet.Shelley.Network.Discriminant ( DecodeAddress (..), DecodeStakeAddress (..), EncodeAddress (..) ) -import Cardano.Wallet.Shelley.Pools - ( StakePool (..), StakePoolFlag (Delisted) ) import Cardano.Wallet.Unsafe ( unsafeFromHex, unsafeMkPercentage ) import Control.Monad diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs index 3d773921e2f..379e5f906a8 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs @@ -73,6 +73,8 @@ import Cardano.Wallet.Api.Types ) import Cardano.Wallet.Api.Types.Transaction ( ApiValidityIntervalExplicit (..) ) +import Cardano.Wallet.Pools + ( StakePool ) import Cardano.Wallet.Primitive.AddressDerivation ( DerivationIndex (..) , HardDerivation (..) @@ -108,8 +110,6 @@ import Cardano.Wallet.Primitive.Types.Tx , getSealedTxBody , sealedTxFromCardanoBody ) -import Cardano.Wallet.Shelley.Pools - ( StakePool ) import Cardano.Wallet.Transaction ( AnyScript (..), ValidityIntervalExplicit (..) ) import Cardano.Wallet.Unsafe diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs b/lib/wallet/src/Cardano/Wallet/Pools.hs similarity index 99% rename from lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs rename to lib/wallet/src/Cardano/Wallet/Pools.hs index c4d712f30dd..d19e4baa8d2 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/wallet/src/Cardano/Wallet/Pools.hs @@ -22,7 +22,7 @@ -- -- This module provides tools to collect a consistent view of stake pool data, -- as provided through @StakePoolLayer@. -module Cardano.Wallet.Shelley.Pools +module Cardano.Wallet.Pools ( StakePoolLayer (..) , StakePool (..) , StakePoolMetrics (..) diff --git a/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 257b09b4c89..534a994c998 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -234,6 +234,12 @@ import Cardano.Wallet.Gen , shrinkPercentage , shrinkTxMetadata ) +import Cardano.Wallet.Pools + ( EpochInfo (..) + , StakePool (StakePool) + , StakePoolFlag + , StakePoolMetrics (StakePoolMetrics) + ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (..) , DerivationIndex (..) @@ -342,12 +348,6 @@ import Cardano.Wallet.Shelley.Network.Discriminant , EncodeAddress (..) , EncodeStakeAddress (..) ) -import Cardano.Wallet.Shelley.Pools - ( EpochInfo (..) - , StakePool (StakePool) - , StakePoolFlag - , StakePoolMetrics (StakePoolMetrics) - ) import Cardano.Wallet.TokenMetadata ( TokenMetadataError (..) ) import Cardano.Wallet.Transaction From 192af55fec3da0e5c7c29ff916f03c2c0f49b39f Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Wed, 26 Oct 2022 10:48:56 +0200 Subject: [PATCH 02/30] chore: quitStakePool readability improvements --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 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 7a063c991d2..231bc0d03ea 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 @@ -3291,9 +3291,7 @@ quitStakePool -> ApiT WalletId -> ApiWalletPassphrase -> Handler (ApiTransaction n) -quitStakePool ctx (ApiT wid) body = do - let pwd = coerce $ getApiT $ body ^. #passphrase - +quitStakePool ctx (ApiT wid) body = withWorkerCtx ctx wid liftE liftE $ \wrk -> do -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read -- @currentNodeEra@ which is not guaranteed with the era read here. This @@ -3327,15 +3325,13 @@ quitStakePool ctx (ApiT wid) body = do $ const Prelude.id sel' <- liftHandler $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel - (tx, txMeta, txTime, sealedTx) <- liftHandler - $ W.buildAndSignTransaction @_ @s @k + (tx, txMeta, txTime, sealedTx) <- do + let pwd = coerce $ getApiT $ body ^. #passphrase + liftHandler $ W.buildAndSignTransaction @_ @s @k wrk wid era mkRwdAcct pwd txCtx sel' liftHandler $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) - mkApiTransaction - (timeInterpreter (ctx ^. networkLayer)) - wrk wid - (#pendingSince) + mkApiTransaction ti wrk wid #pendingSince MkApiTransactionParams { txId = tx ^. #txId , txFee = tx ^. #fee @@ -3351,7 +3347,7 @@ quitStakePool ctx (ApiT wid) body = do , txScriptValidity = tx ^. #scriptValidity , txDeposit = W.stakeKeyDeposit pp , txMetadataSchema = TxMetadataDetailedSchema - , txCBOR = tx ^. #txCBOR + , txCBOR = tx ^. #txCBOR } where ti :: TimeInterpreter (ExceptT PastHorizonException IO) From 9ff1c9f5b860725177bd28f4361e0a2d9122f151 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Wed, 26 Oct 2022 11:59:33 +0200 Subject: [PATCH 03/30] chore: inline "where" bindings to improve local reasoning --- .../api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 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 231bc0d03ea..bea4ebaf552 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 @@ -4473,17 +4473,14 @@ withWorkerCtx -- ^ Do something with the wallet -> m a withWorkerCtx ctx wid onMissing onNotResponding action = - Registry.lookup re wid >>= \case + Registry.lookup (ctx ^. workerRegistry @s @k) wid >>= \case Nothing -> do - wids <- liftIO $ listDatabases df + wids <- liftIO $ listDatabases $ ctx ^. dbFactory @s @k if wid `elem` wids then onNotResponding (ErrWalletNotResponding wid) else onMissing (ErrNoSuchWallet wid) Just wrk -> action $ hoistResource (workerResource wrk) (MsgFromWorker wid) ctx - where - re = ctx ^. workerRegistry @s @k - df = ctx ^. dbFactory @s @k {------------------------------------------------------------------------------- Atomic handler operations From 3710aa9252c993029c555107b670454f06ec02ba Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 10:45:34 +0100 Subject: [PATCH 04/30] chore: reflow comment to fit line width --- lib/wallet/src/Cardano/Wallet.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 4b8e6e3e90b..68117650d2f 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -31,13 +31,14 @@ -- following the convention below: -- -- - @s@: A __s__tate used to keep track of known addresses. Typically, possible --- values for this parameter are described in 'Cardano.Wallet.AddressDiscovery' sub-modules. +-- values for this parameter are described in +-- 'Cardano.Wallet.AddressDiscovery' sub-modules. -- For instance @SeqState@ or @Rnd State@. -- --- - @k@: A __k__ey derivation scheme intrinsically connected to the underlying discovery --- state @s@. This describes how the hierarchical structure of a wallet is --- defined as well as the relationship between secret keys and public --- addresses. +-- - @k@: A __k__ey derivation scheme intrinsically connected to the underlying +-- discovery state @s@. This describes how the hierarchical structure of a +-- wallet is defined as well as the relationship between secret keys and +-- public addresses. module Cardano.Wallet ( From 9b3bd045a589c1225b74ae2d3fa9139aae759939 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 10:41:39 +0100 Subject: [PATCH 05/30] chore: refactor - remove unnecessary parenthesis --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 10 ++-- lib/wallet/src/Cardano/Wallet.hs | 49 ++++++++++++++++++- 2 files changed, 53 insertions(+), 6 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 bea4ebaf552..c1a431b3b8c 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 @@ -2166,7 +2166,7 @@ mkApiTransactionFromInfo ti wrk wid deposit info metadataSchema = do where drop2nd (a,_,c) = (a,c) status :: Lens' (ApiTransaction n) (Maybe ApiBlockReference) - status = case info ^. (#txInfoMeta . #status) of + status = case info ^. #txInfoMeta . #status of Pending -> #pendingSince InLedger -> #insertedAt Expired -> #pendingSince @@ -3604,7 +3604,7 @@ migrateWallet ctx withdrawalType (ApiT wid) postData = do mkApiTransaction (timeInterpreter (ctx ^. networkLayer)) wrk wid - (#pendingSince) + #pendingSince MkApiTransactionParams { txId = tx ^. #txId , txFee = tx ^. #fee @@ -4142,7 +4142,7 @@ mkApiTransaction timeInterpreter wrk wid setTimeReference tx = do , depth = Nothing , direction = ApiT (tx ^. (#txMeta . #direction)) , inputs = - [ ApiTxInput (fmap (toAddressAmount @n) o) (ApiT i) + [ ApiTxInput (toAddressAmount @n <$> o) (ApiT i) | (i, o) <- tx ^. #txInputs ] , collateral = @@ -4153,7 +4153,7 @@ mkApiTransaction timeInterpreter wrk wid setTimeReference tx = do , collateralOutputs = ApiAsArray $ toAddressAmount @n <$> tx ^. #txCollateralOutput , withdrawals = mkApiWithdrawal @n <$> Map.toList (tx ^. #txWithdrawals) - , status = ApiT (tx ^. (#txMeta . #status)) + , status = ApiT (tx ^. #txMeta . #status) , metadata = TxMetadataWithSchema (tx ^. #txMetadataSchema) <$> tx ^. #txMetadata , scriptValidity = ApiT <$> tx ^. #txScriptValidity @@ -4267,7 +4267,7 @@ makeApiBlockReference makeApiBlockReference ti sl height = do slotId <- interpretQuery ti (toSlotId sl) slotTime <- interpretQuery ti (slotToUTCTime sl) - return $ ApiBlockReference + pure ApiBlockReference { absoluteSlotNumber = ApiT sl , slotId = apiSlotId slotId , time = slotTime diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 68117650d2f..fba37e3ab3f 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -14,6 +14,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -2498,7 +2499,7 @@ buildAndSignTransaction -> TransactionCtx -> SelectionOf TxOut -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx) -buildAndSignTransaction ctx wid era mkRwdAcct pwd txCtx sel = db & \DBLayer{..} -> do +buildAndSignTransaction ctx wid era mkRwdAcct pwd txCtx sel = db & \DBLayer{..} -> withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do let pwdP = preparePassphrase scheme pwd mapExceptT atomically $ do @@ -3793,6 +3794,7 @@ data ErrStakePoolDelegation = ErrStakePoolDelegationNoSuchWallet ErrNoSuchWallet | ErrStakePoolJoin ErrCannotJoin | ErrStakePoolQuit ErrCannotQuit + deriving (Show) -- | Errors that can occur when fetching the reward balance of a wallet newtype ErrFetchRewards @@ -3848,6 +3850,51 @@ data ErrWritePolicyPublicKey | ErrWritePolicyPublicKeyWithRootKey ErrWithRootKey deriving (Generic, Eq, Show) +-- | This exception type should gradually replace all cases of `ExceptT Err*` +-- as there is no point in tracking errors at the type level +-- which represent exceptional cases and are always propagated to clients. +data WalletException + = ExceptionSignMetadataWith ErrSignMetadataWith + | ExceptionDerivePublicKey ErrDerivePublicKey + | ExceptionAddCosignerKey ErrAddCosignerKey + | ExceptionConstructSharedWallet ErrConstructSharedWallet + | ExceptionReadAccountPublicKey ErrReadAccountPublicKey + | ExceptionListUTxOStatistics ErrListUTxOStatistics + | ExceptionSignPayment ErrSignPayment + | ExceptionBalanceTx ErrBalanceTx + | ExceptionBalanceTxInternalError ErrBalanceTxInternalError + | ExceptionSubmitTransaction ErrSubmitTransaction + | ExceptionConstructTx ErrConstructTx + | ExceptionGetPolicyId ErrGetPolicyId + | ExceptionWitnessTx ErrWitnessTx + | ExceptionDecodeTx ErrDecodeTx + | ExceptionSubmitTx ErrSubmitTx + | ExceptionUpdatePassphrase ErrUpdatePassphrase + | ExceptionWithRootKey ErrWithRootKey + | ExceptionListTransactions ErrListTransactions + | ExceptionGetTransaction ErrGetTransaction + | ExceptionStartTimeLaterThanEndTime ErrStartTimeLaterThanEndTime + | ExceptionCreateMigrationPlan ErrCreateMigrationPlan + | ExceptionSelectAssets ErrSelectAssets + | ExceptionStakePoolDelegation ErrStakePoolDelegation + | ExceptionFetchRewards ErrFetchRewards + | ExceptionWalletNotResponding ErrWalletNotResponding + | ExceptionCreateRandomAddress ErrCreateRandomAddress + | ExceptionImportRandomAddress ErrImportRandomAddress + | ExceptionNotASequentialWallet ErrNotASequentialWallet + | ExceptionReadRewardAccount ErrReadRewardAccount + | ExceptionWithdrawalNotWorth ErrWithdrawalNotWorth + | ExceptionReadPolicyPublicKey ErrReadPolicyPublicKey + | ExceptionWritePolicyPublicKey ErrWritePolicyPublicKey + | forall level. ExceptionSoftDerivationIndex + (ErrInvalidDerivationIndex 'Soft level) + | forall level. ExceptionHardenedDerivationIndex + (ErrInvalidDerivationIndex 'Hardened level) + +deriving instance (Show WalletException) + +instance Exception WalletException + {------------------------------------------------------------------------------- Utils -------------------------------------------------------------------------------} From e66521dcdbb39c74b866487f85aec671e0e59f3d Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:08:10 +0100 Subject: [PATCH 06/30] replace errors with exceptions --- .../Cardano/Wallet/Api/Http/Server/Error.hs | 79 ++++++++++++++++--- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 7 +- lib/wallet/src/Cardano/Wallet.hs | 36 +++------ 3 files changed, 82 insertions(+), 40 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs index 64d6b7ed8f1..d89c8bda615 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | @@ -16,6 +17,7 @@ module Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..) , liftHandler , liftE + , handleWalletException , apiError , err425 , showT @@ -73,6 +75,7 @@ import Cardano.Wallet , ErrWitnessTx (..) , ErrWritePolicyPublicKey (..) , ErrWrongPassphrase (..) + , WalletException (..) ) import Cardano.Wallet.Api.Types ( Iso8601Time (..) ) @@ -104,8 +107,12 @@ import Cardano.Wallet.Primitive.Types.TokenBundle ( Flat (..) ) import Cardano.Wallet.Transaction ( ErrAssignRedeemers (..), ErrSignTx (..) ) +import Control.Exception + ( try ) import Control.Monad.Except ( ExceptT, withExceptT ) +import Control.Monad.IO.Class + ( liftIO ) import Control.Monad.Trans.Except ( throwE ) import Data.Generics.Internal.VL @@ -133,7 +140,7 @@ import Network.Wai import Safe ( fromJustNote ) import Servant - ( Accept (contentType), JSON, Proxy (Proxy) ) + ( Accept (contentType), JSON, Proxy (Proxy), throwError ) import Servant.Server ( Handler (Handler) , ServerError (..) @@ -170,6 +177,11 @@ class IsServerError e where liftHandler :: IsServerError e => ExceptT e IO a -> Handler a liftHandler action = Handler (withExceptT toServerError action) +handleWalletException :: IO a -> Handler a +handleWalletException action = + liftIO (try @WalletException action) >>= + either (throwError . toServerError) pure + liftE :: IsServerError e => e -> Handler a liftE = liftHandler . throwE @@ -190,6 +202,43 @@ err425 = ServerError 425 "Too early" "" [] showT :: Show a => a -> Text showT = T.pack . show +instance IsServerError WalletException where + toServerError = \case + ExceptionSignMetadataWith e -> toServerError e + ExceptionDerivePublicKey e -> toServerError e + ExceptionAddCosignerKey e -> toServerError e + ExceptionConstructSharedWallet e -> toServerError e + ExceptionReadAccountPublicKey e -> toServerError e + ExceptionListUTxOStatistics e -> toServerError e + ExceptionSignPayment e -> toServerError e + ExceptionBalanceTx e -> toServerError e + ExceptionBalanceTxInternalError e -> toServerError e + ExceptionSubmitTransaction e -> toServerError e + ExceptionConstructTx e -> toServerError e + ExceptionGetPolicyId e -> toServerError e + ExceptionWitnessTx e -> toServerError e + ExceptionDecodeTx e -> toServerError e + ExceptionSubmitTx e -> toServerError e + ExceptionUpdatePassphrase e -> toServerError e + ExceptionWithRootKey e -> toServerError e + ExceptionListTransactions e -> toServerError e + ExceptionGetTransaction e -> toServerError e + ExceptionStartTimeLaterThanEndTime e -> toServerError e + ExceptionCreateMigrationPlan e -> toServerError e + ExceptionSelectAssets e -> toServerError e + ExceptionStakePoolDelegation e -> toServerError e + ExceptionFetchRewards e -> toServerError e + ExceptionWalletNotResponding e -> toServerError e + ExceptionCreateRandomAddress e -> toServerError e + ExceptionImportRandomAddress e -> toServerError e + ExceptionNotASequentialWallet e -> toServerError e + ExceptionReadRewardAccount e -> toServerError e + ExceptionWithdrawalNotWorth e -> toServerError e + ExceptionReadPolicyPublicKey e -> toServerError e + ExceptionWritePolicyPublicKey e -> toServerError e + ExceptionSoftDerivationIndex e -> toServerError e + ExceptionHardenedDerivationIndex e -> toServerError e + instance IsServerError ErrNoSuchWallet where toServerError = \case ErrNoSuchWallet wid -> @@ -447,18 +496,7 @@ instance IsServerError ErrBalanceTx where , "one or more zero-ada outputs. In the future I might be able" , "to increase the values to the minimum allowed ada value." ] - ErrBalanceTxInternalError (ErrFailedBalancing v) -> - apiError err500 BalanceTxInternalError $ T.unwords - [ "I have somehow failed to balance the transaction." - , "The balance is" - , T.pack (show v) - ] - ErrBalanceTxInternalError (ErrUnderestimatedFee c _) -> - apiError err500 BalanceTxUnderestimatedFee $ T.unwords - [ "I have somehow underestimated the fee of the transaction by" - , pretty c - , "and cannot finish balancing." - ] + ErrBalanceTxInternalError e -> toServerError e ErrBalanceTxMaxSizeLimitExceeded -> apiError err403 BalanceTxMaxSizeLimitExceeded $ T.unwords [ "I was not able to balance the transaction without exceeding" @@ -481,6 +519,21 @@ instance IsServerError ErrBalanceTx where , fmt $ blockListF' "-" conflictF conflicts ] +instance IsServerError ErrBalanceTxInternalError where + toServerError = \case + ErrUnderestimatedFee co _st -> + apiError err500 BalanceTxUnderestimatedFee $ T.unwords + [ "I have somehow underestimated the fee of the transaction by" + , pretty co + , "and cannot finish balancing." + ] + ErrFailedBalancing v -> + apiError err500 BalanceTxInternalError $ T.unwords + [ "I have somehow failed to balance the transaction." + , "The balance is" + , T.pack (show v) + ] + instance IsServerError ErrRemoveTx where toServerError = \case ErrRemoveTxNoSuchWallet wid -> toServerError wid 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 c1a431b3b8c..1dd62515411 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 @@ -187,7 +187,7 @@ import Cardano.Wallet.Api , workerRegistry ) import Cardano.Wallet.Api.Http.Server.Error - ( IsServerError (..), apiError, liftE, liftHandler ) + ( IsServerError (..), apiError, handleWalletException, liftE, liftHandler ) import Cardano.Wallet.Api.Http.Server.Handlers.Certificates ( getApiAnyCertificates ) import Cardano.Wallet.Api.Http.Server.Handlers.MintBurn @@ -611,7 +611,7 @@ import UnliftIO.Async import UnliftIO.Concurrent ( threadDelay ) import UnliftIO.Exception - ( IOException, bracket, throwIO, tryAnyDeep, tryJust ) + ( IOException, bracket, tryAnyDeep, tryJust ) import qualified Cardano.Api as Cardano import qualified Cardano.Wallet as W @@ -4378,8 +4378,7 @@ startWalletWorker startWalletWorker ctx coworker = void . registerWorker ctx before coworker where before ctx' wid = - runExceptT (W.checkWalletIntegrity ctx' wid gp) - >>= either throwIO pure + W.checkWalletIntegrity (ctx' ^. typed @(DBLayer IO s k)) wid gp (_, NetworkParameters gp _ _) = ctx ^. genesisData -- | Register a wallet create and restore thread with the worker registry. diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index fba37e3ab3f..edef43b2a3a 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -42,12 +42,10 @@ -- public addresses. module Cardano.Wallet - ( - -- * Development - -- $Development + ( WalletException (..) -- * WalletLayer - WalletLayer (..) + , WalletLayer (..) -- * Capabilities -- $Capabilities @@ -481,6 +479,8 @@ import Control.Arrow ( first, left ) import Control.DeepSeq ( NFData ) +import Control.Exception + ( throw ) import Control.Monad ( forM, forM_, replicateM, unless, when ) import Control.Monad.Class.MonadTime @@ -822,25 +822,15 @@ createIcarusWallet ctx wid wname credentials = db & \DBLayer{..} -> do (block0, NetworkParameters gp _sp _pp) = ctx ^. genesisData -- | Check whether a wallet is in good shape when restarting a worker. -checkWalletIntegrity - :: forall ctx s k. HasDBLayer IO s k ctx - => ctx - -> WalletId - -> GenesisParameters - -> ExceptT ErrCheckWalletIntegrity IO () -checkWalletIntegrity ctx wid gp = db & \DBLayer{..} -> mapExceptT atomically $ do - gp' <- withExceptT ErrCheckWalletIntegrityNoSuchWallet $ withNoSuchWallet wid $ - readGenesisParameters wid - - whenDifferentGenesis gp gp $ throwE $ - ErrCheckIntegrityDifferentGenesis - (getGenesisBlockHash gp) - (getGenesisBlockHash gp') - where - db = ctx ^. dbLayer @IO @s @k - whenDifferentGenesis bp1 bp2 = when $ - (bp1 ^. #getGenesisBlockHash /= bp2 ^. #getGenesisBlockHash) || - (bp1 ^. #getGenesisBlockDate /= bp2 ^. #getGenesisBlockDate) +checkWalletIntegrity :: DBLayer IO s k -> WalletId -> GenesisParameters -> IO () +checkWalletIntegrity db walletId gp = db & \DBLayer{..} -> do + gp' <- atomically (readGenesisParameters walletId) >>= do + let noSuchWallet = ErrNoSuchWallet walletId + maybe (throw $ ErrCheckWalletIntegrityNoSuchWallet noSuchWallet) pure + when ( (gp ^. #getGenesisBlockHash /= gp' ^. #getGenesisBlockHash) || + (gp ^. #getGenesisBlockDate /= gp' ^. #getGenesisBlockDate) ) + (throw $ ErrCheckIntegrityDifferentGenesis + (getGenesisBlockHash gp) (getGenesisBlockHash gp')) -- | Retrieve the wallet state for the wallet with the given ID. readWallet From ae9d163aa4bbac137d218c91f2bccfff0172a796 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:10:19 +0100 Subject: [PATCH 07/30] refactor: inline queryRewardBalance --- lib/wallet/src/Cardano/Wallet.hs | 21 ++------------------- 1 file changed, 2 insertions(+), 19 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index edef43b2a3a..c6abf31b3cb 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -84,7 +84,6 @@ module Cardano.Wallet , someRewardAccount , readPolicyPublicKey , writePolicyPublicKey - , queryRewardBalance , ErrWalletAlreadyExists (..) , ErrNoSuchWallet (..) , ErrListUTxOStatistics (..) @@ -1318,22 +1317,6 @@ readPolicyPublicKey ctx wid = db & \DBLayer{..} -> do where db = ctx ^. dbLayer @IO @s @k --- | Query the node for the reward balance of a given wallet. --- --- Rather than force all callers of 'readWallet' to wait for fetching the --- account balance (via the 'NetworkLayer'), we expose this function for it. -queryRewardBalance - :: forall ctx. - ( HasNetworkLayer IO ctx - ) - => ctx - -> RewardAccount - -> ExceptT ErrFetchRewards IO Coin -queryRewardBalance ctx acct = do - liftIO $ getCachedRewardAccountBalance nw acct - where - nw = ctx ^. networkLayer - manageRewardBalance :: forall ctx s k (n :: NetworkDiscriminant). ( HasLogger IO WalletWorkerLog ctx @@ -1351,8 +1334,8 @@ manageRewardBalance _ ctx wid = db & \DBLayer{..} -> do traceWith tr $ MsgRewardBalanceQuery bh query <- runExceptT $ do (acct, _, _) <- withExceptT ErrFetchRewardsReadRewardAccount $ - readRewardAccount @ctx @s @k @n ctx wid - queryRewardBalance @ctx ctx acct + readRewardAccount @s @k @n db wid + liftIO $ getCachedRewardAccountBalance (ctx ^. networkLayer) acct traceWith tr $ MsgRewardBalanceResult query case query of Right amt -> do From 9a6b0c7faf0e9a1b641c408fb89e424a4d6defcc Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:11:22 +0100 Subject: [PATCH 08/30] refactor: remove unused ErrMintBurnAssets --- lib/wallet/src/Cardano/Wallet.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index c6abf31b3cb..81b90cb06af 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -133,7 +133,6 @@ module Cardano.Wallet , ErrNotASequentialWallet (..) , ErrWithdrawalNotWorth (..) , ErrConstructTx (..) - , ErrMintBurnAssets (..) , ErrBalanceTx (..) , ErrBalanceTxInternalError (..) , ErrUpdateSealedTx (..) @@ -3690,11 +3689,6 @@ data ErrGetPolicyId | ErrGetPolicyIdWrongMintingBurningTemplate deriving (Show, Eq) -newtype ErrMintBurnAssets - = ErrMintBurnNotImplemented T.Text - -- ^ Temporary error constructor. - deriving (Show, Eq) - -- | Errors that can occur when signing a transaction. data ErrWitnessTx = ErrWitnessTxSignTx ErrSignTx From 00e6cf46505e89b139f0959ea383b92d2930f8e8 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:19:11 +0100 Subject: [PATCH 09/30] chore: formatting and syntax improvements --- .../http/Cardano/Wallet/Api/Http/Server.hs | 4 +- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 24 ++++---- .../api/http/Cardano/Wallet/Api/Link.hs | 47 ++++----------- lib/wallet/src/Cardano/Wallet.hs | 59 ++++++++----------- 4 files changed, 49 insertions(+), 85 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs index 2b969fe3299..b1dee5f7d4d 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs @@ -507,7 +507,7 @@ server byron icarus shelley multisig spl ntp blockchainSource = (icarus, deleteTransaction icarus wid txid) ) :<|> (\wid tx -> withLegacyLayer wid - (byron , do + (byron, do let pwd = coerce (getApiT $ tx ^. #passphrase) genChange <- rndStateChange byron wid pwd postTransactionOld byron genChange wid tx @@ -519,7 +519,7 @@ server byron icarus shelley multisig spl ntp blockchainSource = ) ) :<|> (\wid tx -> withLegacyLayer wid - (byron , postTransactionFeeOld byron wid tx) + (byron, postTransactionFeeOld byron wid tx) (icarus, postTransactionFeeOld icarus wid tx) ) 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 1dd62515411..96f7f08001a 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 @@ -2218,7 +2218,9 @@ postTransactionFeeOld ctx (ApiT wid) body = do let runSelection = W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams getFee - minCoins <- liftIO (W.calcMinimumCoinValues @_ @k @'CredFromKeyK wrk era (F.toList outs)) + minCoins <- liftIO + $ W.calcMinimumCoinValues @_ @k @'CredFromKeyK + wrk era (F.toList outs) liftHandler $ mkApiFee Nothing minCoins <$> W.estimateFee runSelection constructTransaction @@ -3199,19 +3201,18 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do , selectionStrategy = SelectionStrategyOptimal } sel <- liftHandler - $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams - $ const Prelude.id + $ W.selectAssets @_ @_ @s @k @'CredFromKeyK + wrk era pp selectAssetsParams (const Prelude.id) sel' <- liftHandler $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel (tx, txMeta, txTime, sealedTx) <- liftHandler $ W.buildAndSignTransaction @_ @s @k wrk wid era mkRwdAcct pwd txCtx sel' - liftHandler - $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) + liftHandler $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) mkApiTransaction (timeInterpreter (ctx ^. networkLayer)) wrk wid - (#pendingSince) + #pendingSince MkApiTransactionParams { txId = tx ^. #txId , txFee = tx ^. #fee @@ -3310,7 +3311,9 @@ quitStakePool ctx (ApiT wid) body = liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - let selectAssetsParams = W.SelectAssetsParams + sel <- liftHandler + $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp + W.SelectAssetsParams { outputs = [] , pendingTxs , randomSeed = Nothing @@ -3320,8 +3323,6 @@ quitStakePool ctx (ApiT wid) body = , wallet , selectionStrategy = SelectionStrategyOptimal } - sel <- liftHandler - $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams $ const Prelude.id sel' <- liftHandler $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel @@ -3386,8 +3387,7 @@ listStakeKeys' utxo lookupStakeRef fetchRewards ourKeysWithInfo = do -- `NetworkLayer` interface. rewardsMap <- fetchRewards $ Set.fromList allKeys - let rewards acc = fromMaybe (Coin 0) $ - Map.lookup acc rewardsMap + let rewards acc = fromMaybe (Coin 0) $ Map.lookup acc rewardsMap let mkOurs (acc, ix, deleg) = ApiOurStakeKey { _index = ix @@ -4085,8 +4085,6 @@ data MkApiTransactionParams = MkApiTransactionParams } deriving (Eq, Generic, Show) - - mkApiTransaction :: forall n s k . (Typeable s, Typeable n, HasDelegation s) => TimeInterpreter (ExceptT PastHorizonException IO) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs index f3784ea73b8..4277f14a854 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Link.hs @@ -785,7 +785,7 @@ getPoolMaintenance = endpoint @Api.GetPoolMaintenance id listStakePools :: Maybe Coin -> (Method, Text) listStakePools stake = endpoint @Api.ListStakePools ($ ApiT <$> stake) -listStakeKeys :: forall w. (HasType (ApiT WalletId) w) => w -> (Method, Text) +listStakeKeys :: forall w. HasType (ApiT WalletId) w => w -> (Method, Text) listStakeKeys w = endpoint @(Api.ListStakeKeys ()) ($ w^.typed @(ApiT WalletId)) joinStakePool @@ -796,31 +796,18 @@ joinStakePool => s -> w -> (Method, Text) -joinStakePool s w = - endpoint @(Api.JoinStakePool Net) (\mk -> mk sid wid) +joinStakePool s w = endpoint @(Api.JoinStakePool Net) (\mk -> mk sid wid) where sid = s ^. typed @ApiPoolSpecifier wid = w ^. typed @(ApiT WalletId) -quitStakePool - :: forall w. - ( HasType (ApiT WalletId) w - ) - => w - -> (Method, Text) -quitStakePool w = - endpoint @(Api.QuitStakePool Net) (wid &) +quitStakePool :: forall w. HasType (ApiT WalletId) w => w -> (Method, Text) +quitStakePool w = endpoint @(Api.QuitStakePool Net) (wid &) where wid = w ^. typed @(ApiT WalletId) -getDelegationFee - :: forall w. - ( HasType (ApiT WalletId) w - ) - => w - -> (Method, Text) -getDelegationFee w = - endpoint @Api.DelegationFee (wid &) +getDelegationFee :: forall w. HasType (ApiT WalletId) w => w -> (Method, Text) +getDelegationFee w = endpoint @Api.DelegationFee (wid &) where wid = w ^. typed @(ApiT WalletId) @@ -828,27 +815,19 @@ getDelegationFee w = -- Network Information -- -getNetworkInfo - :: (Method, Text) -getNetworkInfo = - endpoint @Api.GetNetworkInformation id +getNetworkInfo :: (Method, Text) +getNetworkInfo = endpoint @Api.GetNetworkInformation id -getNetworkParams - :: (Method, Text) -getNetworkParams = - endpoint @Api.GetNetworkParameters id +getNetworkParams :: (Method, Text) +getNetworkParams = endpoint @Api.GetNetworkParameters id -getNetworkClock - :: (Method, Text) -getNetworkClock = - endpoint @Api.GetNetworkClock (False &) +getNetworkClock :: (Method, Text) +getNetworkClock = endpoint @Api.GetNetworkClock (False &) getNetworkClock' :: Bool -- ^ When 'True', block and force NTP check -> (Method, Text) -getNetworkClock' forceNtpCheck = - endpoint @Api.GetNetworkClock (forceNtpCheck &) - +getNetworkClock' forceNtpCheck = endpoint @Api.GetNetworkClock (forceNtpCheck &) -- -- Proxy diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 81b90cb06af..5775a8c4fc1 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -720,35 +720,24 @@ type HasNetworkLayer m = HasType (NetworkLayer m Block) type HasTransactionLayer k ktype = HasType (TransactionLayer k ktype SealedTx) -dbLayer - :: forall m s k ctx. HasDBLayer m s k ctx - => Lens' ctx (DBLayer m s k) -dbLayer = - typed @(DBLayer m s k) - -genesisData - :: forall ctx. HasGenesisData ctx - => Lens' ctx (Block, NetworkParameters) -genesisData = - typed @(Block, NetworkParameters) - -logger - :: forall m msg ctx. HasLogger m msg ctx - => Lens' ctx (Tracer m msg) -logger = - typed @(Tracer m msg) - -networkLayer - :: forall m ctx. (HasNetworkLayer m ctx) - => Lens' ctx (NetworkLayer m Block) -networkLayer = - typed @(NetworkLayer m Block) - -transactionLayer - :: forall k ktype ctx. (HasTransactionLayer k ktype ctx) +dbLayer :: forall m s k ctx. HasDBLayer m s k ctx => Lens' ctx (DBLayer m s k) +dbLayer = typed @(DBLayer m s k) + +genesisData :: + forall ctx. HasGenesisData ctx => Lens' ctx (Block, NetworkParameters) +genesisData = typed @(Block, NetworkParameters) + +logger :: forall m msg ctx. HasLogger m msg ctx => Lens' ctx (Tracer m msg) +logger = typed @(Tracer m msg) + +networkLayer :: + forall m ctx. (HasNetworkLayer m ctx) => Lens' ctx (NetworkLayer m Block) +networkLayer = typed @(NetworkLayer m Block) + +transactionLayer :: + forall k ktype ctx. (HasTransactionLayer k ktype ctx) => Lens' ctx (TransactionLayer k ktype SealedTx) -transactionLayer = - typed @(TransactionLayer k ktype SealedTx) +transactionLayer = typed @(TransactionLayer k ktype SealedTx) {------------------------------------------------------------------------------- Wallet @@ -3496,7 +3485,8 @@ guardSoftIndex => DerivationIndex -> ExceptT (ErrInvalidDerivationIndex 'Soft 'CredFromKeyK) m (Index 'Soft whatever) guardSoftIndex ix = - if ix > DerivationIndex (getIndex @'Soft maxBound) || ix < DerivationIndex (getIndex @'Soft minBound) + if ix > DerivationIndex (getIndex @'Soft maxBound) || + ix < DerivationIndex (getIndex @'Soft minBound) then throwE $ ErrIndexOutOfBound minBound maxBound ix else pure (Index $ getDerivationIndex ix) @@ -3505,7 +3495,8 @@ guardHardIndex => DerivationIndex -> ExceptT (ErrInvalidDerivationIndex 'Hardened level) m (Index 'Hardened whatever) guardHardIndex ix = - if ix > DerivationIndex (getIndex @'Hardened maxBound) || ix < DerivationIndex (getIndex @'Hardened minBound) + if ix > DerivationIndex (getIndex @'Hardened maxBound) || + ix < DerivationIndex (getIndex @'Hardened minBound) then throwE $ ErrIndexOutOfBound minBound maxBound ix else pure (Index $ getDerivationIndex ix) @@ -3906,11 +3897,7 @@ guardJoin knownPools delegation pid mRetirementEpochInfo = do where WalletDelegation {active, next} = delegation -guardQuit - :: WalletDelegation - -> Withdrawal - -> Coin - -> Either ErrCannotQuit () +guardQuit :: WalletDelegation -> Withdrawal -> Coin -> Either ErrCannotQuit () guardQuit WalletDelegation{active,next} wdrl rewards = do let last_ = maybe active (view #status) $ lastMay next @@ -4164,7 +4151,7 @@ posAndNegFromCardanoValue = foldMap go . Cardano.valueToList -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle) go (Cardano.AdaAssetId, q) = partition q $ TokenBundle.fromCoin . Coin.fromNatural - go ((Cardano.AssetId policy name), q) = partition q $ \n -> + go (Cardano.AssetId policy name, q) = partition q $ \n -> TokenBundle.fromFlatList (Coin 0) [ ( TokenBundle.AssetId (mkPolicyId policy) (mkTokenName name) , TokenQuantity n From 61f092fb36210c809574be7c7e44ffb83f30743b Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:26:49 +0100 Subject: [PATCH 10/30] remove unnecessary polymorphism --- .../Api/Http/Server/Handlers/Certificates.hs | 20 +-- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 119 +++++++++--------- lib/wallet/src/Cardano/Wallet.hs | 25 ++-- 3 files changed, 75 insertions(+), 89 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs index 167cc251c17..eccb255c095 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs @@ -22,12 +22,18 @@ import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR ( ParsedTxCBOR (..) ) import Cardano.Wallet.Api.Types.Certificate ( ApiAnyCertificate, mkApiAnyCertificate ) +import Cardano.Wallet.DB + ( DBLayer ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (CredFromKeyK) ) import Cardano.Wallet.Primitive.Types ( WalletId ) import Cardano.Wallet.Registry ( WorkerCtx ) +import Data.Generics.Internal.VL + ( (^.) ) +import Data.Generics.Product + ( typed ) import Data.Typeable ( Typeable ) import Prelude hiding @@ -40,16 +46,14 @@ import qualified Cardano.Wallet as W -- | Promote certificates of a transaction to API type, -- using additional context from the 'WorkerCtx'. getApiAnyCertificates - :: forall ctx s k n. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , Typeable s - , Typeable n - ) - => WorkerCtx ctx + :: forall s k n + . (Typeable s, Typeable n) + => WorkerCtx (ApiLayer s k 'CredFromKeyK) -> WalletId -> ParsedTxCBOR -> Handler [ApiAnyCertificate n] getApiAnyCertificates wrk wid ParsedTxCBOR{certificates} = do - (acct, _, acctPath) <- - liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid + (acct, _, acctPath) <- liftHandler $ W.readRewardAccount @s @k @n db wid pure $ mkApiAnyCertificate acct acctPath <$> certificates + where + db = wrk ^. typed @(DBLayer IO s k) 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 96f7f08001a..39c8d72b1b1 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 @@ -335,7 +335,7 @@ import Cardano.Wallet.CoinSelection import Cardano.Wallet.Compat ( (^?) ) import Cardano.Wallet.DB - ( DBFactory (..) ) + ( DBFactory (..), DBLayer ) import Cardano.Wallet.Network ( NetworkLayer (..), fetchRewardAccountBalances, timeInterpreter ) import Cardano.Wallet.Pools @@ -540,6 +540,8 @@ import Data.Generics.Internal.VL.Lens ( Lens', view, (.~), (^.) ) import Data.Generics.Labels () +import Data.Generics.Product + ( typed ) import Data.List ( isInfixOf, sortOn, (\\) ) import Data.List.NonEmpty @@ -865,9 +867,10 @@ mkShelleyWallet ) => MkApiWallet ctx s ApiWallet mkShelleyWallet ctx wid cp meta delegation pending progress = do - reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> + reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> do + let db = wrk ^. typed @(DBLayer IO s k) -- never fails - returns zero if balance not found - liftIO $ W.fetchRewardBalance @_ @s @k wrk wid + liftIO $ W.fetchRewardBalance @s @k db wid let ti = timeInterpreter $ ctx ^. networkLayer @@ -1065,9 +1068,10 @@ mkSharedWallet ctx wid cp meta delegation pending progress = case Shared.ready s , delegationScriptTemplate = Shared.delegationTemplate st } Shared.Active _ -> do - reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> + reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> do + let db = wrk ^. typed @(DBLayer IO s k) -- never fails - returns zero if balance not found - liftIO $ W.fetchRewardBalance @_ @s @k wrk wid + liftIO $ W.fetchRewardBalance @s @k db wid let ti = timeInterpreter $ ctx ^. networkLayer apiDelegation <- liftIO $ toApiWalletDelegation delegation @@ -1699,9 +1703,10 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do , selectionStrategy = SelectionStrategyOptimal } utx <- liftHandler - $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform + $ W.selectAssets @_ @_ @s @k @'CredFromKeyK + wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler - $ W.readRewardAccount @_ @s @k @n wrk wid + $ W.readRewardAccount @s @k @n (wrk ^. typed @(DBLayer IO s k)) wid let deposits = maybeToList deposit @@ -1718,7 +1723,7 @@ selectCoinsForQuit , WalletKey k , BoundedAddressLength k ) - => ctx + => ApiLayer (SeqState n k) k 'CredFromKeyK -> ApiT WalletId -> Handler (Api.ApiCoinSelection n) selectCoinsForQuit ctx (ApiT wid) = do @@ -1739,7 +1744,7 @@ selectCoinsForQuit ctx (ApiT wid) = do W.assignChangeAddresses (delegationAddress @n) sel s & uncurry (W.selectionToUnsignedTx (txWithdrawal txCtx)) (utxoAvailable, wallet, pendingTxs) <- - liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid + liftHandler $ W.readWalletUTxOIndex @_ @(SeqState n k) @k wrk wid pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) let refund = W.stakeKeyDeposit pp @@ -1754,8 +1759,10 @@ selectCoinsForQuit ctx (ApiT wid) = do , selectionStrategy = SelectionStrategyOptimal } utx <- liftHandler - $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform - (_, _, path) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid + $ W.selectAssets @_ @_ @(SeqState n k) @k @'CredFromKeyK + wrk era pp selectAssetsParams transform + (_, _, path) <- liftHandler + $ W.readRewardAccount @(SeqState n k) @k @n db wid pure $ mkApiCoinSelection [] [refund] (Just (action, path)) Nothing utx @@ -2172,33 +2179,23 @@ mkApiTransactionFromInfo ti wrk wid deposit info metadataSchema = do Expired -> #pendingSince postTransactionFeeOld - :: forall ctx s k n. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) - , HardDerivation k - , Typeable n - , Typeable s - , WalletKey k - , BoundedAddressLength k - ) - => ctx + :: forall s k n + . (Typeable n, Typeable s, BoundedAddressLength k) + => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> PostTransactionFeeOldData n -> Handler ApiFee -postTransactionFeeOld ctx (ApiT wid) body = do - - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, _) <- mkRewardAccountBuilder @_ @s @_ @n ctx wid (body ^. #withdrawal) - let txCtx = defaultTransactionCtx - { txWithdrawal = wdrl - , txMetadata - = body ^? #metadata - . traverse - . #txMetadataWithSchema_metadata - } +postTransactionFeeOld ctx (ApiT wid) body = withWorkerCtx ctx wid liftE liftE $ \wrk -> do + era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + wdrl <- case body ^. #withdrawal of + Nothing -> pure NoWithdrawal + Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl + let txCtx = defaultTransactionCtx + { txWithdrawal = wdrl + , txMetadata = body + ^? #metadata . traverse . #txMetadataWithSchema_metadata + } (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid let outs = addressAmountToTxOut <$> body ^. #payments @@ -2330,6 +2327,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do mkRewardAccountBuilder @_ @s @_ @n ctx wid apiwithdrawal withWorkerCtx ctx wid liftE liftE $ \wrk -> do + let db = wrk ^. typed @(DBLayer IO s k) pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) (deposit, refund, txCtx) <- case body ^. #delegations of @@ -2868,8 +2866,9 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do , scriptValidity } = decodedTx withWorkerCtx ctx wid liftE liftE $ \wrk -> do + let db = wrk ^. typed @(DBLayer IO s k) (acct, _, acctPath) <- - liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid + liftHandler $ W.readRewardAccount @s @k @n db wid inputPaths <- liftHandler $ W.lookupTxIns @_ @s @k wrk wid $ fst <$> resolvedInputs @@ -3004,7 +3003,8 @@ submitTransaction ctx apiw@(ApiT wid) apitx = do ErrSubmitTransactionPartiallySignedOrNoSignedTx witsRequiredForInputs totalNumberOfWits _ <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do - (acct, _, path) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid + let db = wrk ^. typed @(DBLayer IO s k) + (acct, _, path) <- liftHandler $ W.readRewardAccount @s @k @n db wid let wdrl = getOurWdrl acct path apiDecoded let txCtx = defaultTransactionCtx { -- TODO: [ADP-1193] @@ -3433,23 +3433,24 @@ listStakeKeys -> Handler (ApiStakeKeys n) listStakeKeys lookupStakeRef ctx (ApiT wid) = do withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do - (wal, (_, delegation) ,pending) <- W.readWallet @_ @s @k wrk wid - let utxo = availableUTxO @s pending wal - - let takeFst (a,_,_) = a - mourAccount <- fmap (fmap takeFst . eitherToMaybe) - <$> liftIO . runExceptT $ W.readRewardAccount @_ @s @k @n wrk wid - ourApiDelegation <- liftIO $ toApiWalletDelegation delegation - (unsafeExtendSafeZone (timeInterpreter $ ctx ^. networkLayer)) - let ourKeys = case mourAccount of - Just acc -> [(acc, 0, ourApiDelegation)] - Nothing -> [] - - liftIO $ listStakeKeys' @n - utxo - lookupStakeRef - (fetchRewardAccountBalances nl) - ourKeys + let db = wrk ^. typed @(DBLayer IO s k) + (wal, (_, delegation) ,pending) <- W.readWallet @_ @s @k wrk wid + let utxo = availableUTxO @s pending wal + + let takeFst (a,_,_) = a + mourAccount <- fmap (fmap takeFst . eitherToMaybe) + <$> liftIO . runExceptT $ W.readRewardAccount @s @k @n db wid + ourApiDelegation <- liftIO $ toApiWalletDelegation delegation + (unsafeExtendSafeZone (timeInterpreter $ ctx ^. networkLayer)) + let ourKeys = case mourAccount of + Just acc -> [(acc, 0, ourApiDelegation)] + Nothing -> [] + + liftIO $ listStakeKeys' @n + utxo + lookupStakeRef + (fetchRewardAccountBalances nl) + ourKeys where nl = ctx ^. networkLayer @@ -3458,16 +3459,8 @@ listStakeKeys lookupStakeRef ctx (ApiT wid) = do -------------------------------------------------------------------------------} createMigrationPlan - :: forall ctx n s k. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) - , HardDerivation k - , IsOwned s k 'CredFromKeyK - , Typeable n - , Typeable s - , WalletKey k - ) - => ctx + :: forall n s k. (IsOwned s k 'CredFromKeyK, Typeable n, Typeable s) + => ApiLayer s k 'CredFromKeyK -> Maybe ApiWithdrawalPostData -- ^ What type of reward withdrawal to attempt -> ApiT WalletId diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 5775a8c4fc1..d3db8b61f0b 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1195,17 +1195,9 @@ deleteWallet ctx wid = db & \DBLayer{..} -> do db = ctx ^. dbLayer @IO @s @k -- | Fetch the cached reward balance of a given wallet from the database. -fetchRewardBalance - :: forall ctx s k. - ( HasDBLayer IO s k ctx - ) - => ctx - -> WalletId - -> IO Coin -fetchRewardBalance ctx wid = db & \DBLayer{..} -> +fetchRewardBalance :: forall s k. DBLayer IO s k -> WalletId -> IO Coin +fetchRewardBalance db wid = db & \DBLayer{..} -> atomically $ readDelegationRewardBalance wid - where - db = ctx ^. dbLayer @IO @s @k -- | Read the current withdrawal capacity of a wallet. Note that, this simply -- returns 0 if: @@ -1251,16 +1243,15 @@ readNextWithdrawal ctx era (Coin withdrawal) = do DerivationIndex 0 :| [] readRewardAccount - :: forall ctx s k (n :: NetworkDiscriminant) shelley. - ( HasDBLayer IO s k ctx - , shelley ~ SeqState n ShelleyKey + :: forall s k (n :: NetworkDiscriminant) shelley. + ( shelley ~ SeqState n ShelleyKey , Typeable n , Typeable s ) - => ctx + => DBLayer IO s k -> WalletId -> ExceptT ErrReadRewardAccount IO (RewardAccount, XPub, NonEmpty DerivationIndex) -readRewardAccount ctx wid = db & \DBLayer{..} -> do +readRewardAccount db wid = db & \DBLayer{..} -> do cp <- withExceptT ErrReadRewardAccountNoSuchWallet $ mapExceptT atomically $ withNoSuchWallet wid @@ -1274,8 +1265,6 @@ readRewardAccount ctx wid = db & \DBLayer{..} -> do let acct = toRewardAccount xpub let path = stakeDerivationPath $ Seq.derivationPrefix s pure (acct, getRawKey xpub, path) - where - db = ctx ^. dbLayer @IO @s @k readPolicyPublicKey :: forall ctx s k (n :: NetworkDiscriminant) shelley. @@ -2499,7 +2488,7 @@ constructTransaction -> ExceptT ErrConstructTx IO SealedTx constructTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do (_, xpub, _) <- withExceptT ErrConstructTxReadRewardAccount $ - readRewardAccount @ctx @s @k @n ctx wid + readRewardAccount @s @k @n db wid mapExceptT atomically $ do pp <- liftIO $ currentProtocolParameters nl withExceptT ErrConstructTxBody $ ExceptT $ pure $ From dfc9d36547110ba328336020d4bd895f030da491 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:35:28 +0100 Subject: [PATCH 11/30] refactor: break mkRewardAccountBuilder into smaller functions --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 268 +++++++++--------- 1 file changed, 136 insertions(+), 132 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 39c8d72b1b1..b0ba764ed9b 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 @@ -136,7 +136,12 @@ import Cardano.Address.Script , validateScriptOfTemplate ) import Cardano.Api - ( NetworkId, SerialiseAsCBOR (..), toNetworkMagic, unNetworkMagic ) + ( AnyCardanoEra + , NetworkId + , SerialiseAsCBOR (..) + , toNetworkMagic + , unNetworkMagic + ) import Cardano.Api.Extra ( inAnyCardanoEra ) import Cardano.Api.Shelley @@ -572,7 +577,7 @@ import Data.Text.Class import Data.Time ( UTCTime ) import Data.Type.Equality - ( (:~:) (..), type (==), testEquality ) + ( type (==), testEquality ) import Data.Word ( Word32 ) import Fmt @@ -1604,13 +1609,10 @@ getWalletUtxoSnapshot ctx (ApiT wid) = do selectCoins :: forall ctx s k n. ( ctx ~ ApiLayer s k 'CredFromKeyK - , SoftDerivation k , IsOurs s Address , GenChange s - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) , Typeable n , Typeable s - , WalletKey k , BoundedAddressLength k ) => ctx @@ -1620,14 +1622,11 @@ selectCoins -> Handler (ApiCoinSelection n) selectCoins ctx genChange (ApiT wid) body = do let md = body ^? #metadata . traverse . #getApiT - - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, _) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid (body ^. #withdrawal) - withWorkerCtx ctx wid liftE liftE $ \wrk -> do + era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + wdrl <- case body ^. #withdrawal of + Nothing -> pure NoWithdrawal + Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl let outs = addressAmountToTxOut <$> body ^. #payments let txCtx = defaultTransactionCtx { txWithdrawal = wdrl @@ -1639,7 +1638,6 @@ selectCoins ctx genChange (ApiT wid) body = do (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) let selectAssetsParams = W.SelectAssetsParams { outputs = F.toList outs , pendingTxs @@ -1713,27 +1711,21 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do pure $ mkApiCoinSelection deposits [] (Just (action, path)) Nothing utx selectCoinsForQuit - :: forall ctx s n k. - ( s ~ SeqState n k - , ctx ~ ApiLayer s k 'CredFromKeyK - , DelegationAddress n k 'CredFromKeyK + :: forall n k. + ( DelegationAddress n k 'CredFromKeyK , Seq.SupportsDiscovery n k - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) - , Typeable s - , WalletKey k , BoundedAddressLength k + , Typeable k ) => ApiLayer (SeqState n k) k 'CredFromKeyK -> ApiT WalletId -> Handler (Api.ApiCoinSelection n) selectCoinsForQuit ctx (ApiT wid) = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, _mkRwdAcct) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid (Just SelfWithdrawal) - action <- liftHandler $ W.quitStakePool @_ @s @k wrk wid wdrl + let db = wrk ^. typed @(DBLayer IO (SeqState n k) k) + wdrl <- liftHandler $ mkSelfWithdrawal @_ @k @n wrk wid + action <- handleWalletException + $ W.validatedQuitStakePoolAction @(SeqState n k) @k db wid wdrl let txCtx = defaultTransactionCtx { txDelegationAction = Just action @@ -1998,26 +1990,23 @@ postTransactionOld ctx genChange (ApiT wid) body = do let md = body ^? #metadata . traverse . #txMetadataWithSchema_metadata let mTTL = body ^? #timeToLive . traverse . #getQuantity - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, mkRwdAcct) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid (body ^. #withdrawal) - - ttl <- liftIO $ W.getTxExpiry ti mTTL - let txCtx = defaultTransactionCtx - { txWithdrawal = wdrl - , txMetadata = md - , txValidityInterval = (Nothing, ttl) - } - + mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (body ^. #withdrawal) withWorkerCtx ctx wid liftE liftE $ \wrk -> do + era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + ttl <- liftIO $ W.getTxExpiry ti mTTL + wdrl <- case body ^. #withdrawal of + Nothing -> pure NoWithdrawal + Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl + let txCtx = defaultTransactionCtx + { txWithdrawal = wdrl + , txMetadata = md + , txValidityInterval = (Nothing, ttl) + } (sel, tx, txMeta, txTime, pp) <- atomicallyWithHandler (ctx ^. walletLocks) (PostTransactionOld wid) $ do (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) let selectAssetsParams = W.SelectAssetsParams { outputs = F.toList outs , pendingTxs @@ -2200,7 +2189,6 @@ postTransactionFeeOld ctx (ApiT wid) body = liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid let outs = addressAmountToTxOut <$> body ^. #payments pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) let getFee = const (selectionDelta TokenBundle.getCoin) let selectAssetsParams = W.SelectAssetsParams { outputs = F.toList outs @@ -2223,9 +2211,7 @@ postTransactionFeeOld ctx (ApiT wid) body = constructTransaction :: forall ctx s k n. ( ctx ~ ApiLayer s k 'CredFromKeyK - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) , GenChange s - , HardDerivation k , HasNetworkLayer IO ctx , IsOurs s Address , Typeable n @@ -2317,19 +2303,13 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do $ liftHandler $ throwE ErrConstructTxValidityIntervalNotWithinScriptTimelock - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - let apiwithdrawal = case body ^. #withdrawal of - Just SelfWithdraw -> Just SelfWithdrawal - _ -> Nothing - (wdrl, _) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid apiwithdrawal - withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO s k) pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + wdrl <- case body ^. #withdrawal of + Just SelfWithdraw -> liftHandler $ mkSelfWithdrawal @_ @k @n wrk wid + _ -> pure NoWithdrawal (deposit, refund, txCtx) <- case body ^. #delegations of Nothing -> pure (Nothing, Nothing, defaultTransactionCtx { txWithdrawal = wdrl @@ -3162,7 +3142,6 @@ joinStakePool -> ApiWalletPassphrase -> Handler (ApiTransaction n) joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do - let pwd = coerce $ getApiT $ body ^. #passphrase poolId <- case apiPool of AllPools -> liftE ErrUnexpectedPoolIdPlaceholder SpecificPool pool -> pure pool @@ -3174,13 +3153,9 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do (action, _) <- liftHandler $ W.joinStakePool @_ @s @k wrk curEpoch pools poolId poolStatus wid - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, mkRwdAcct) <- mkRewardAccountBuilder @_ @s @_ @n ctx wid Nothing ttl <- liftIO $ W.getTxExpiry ti Nothing let txCtx = defaultTransactionCtx - { txWithdrawal = wdrl + { txWithdrawal = NoWithdrawal , txValidityInterval = (Nothing, ttl) , txDelegationAction = Just action } @@ -3205,8 +3180,10 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do wrk era pp selectAssetsParams (const Prelude.id) sel' <- liftHandler $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel - (tx, txMeta, txTime, sealedTx) <- liftHandler - $ W.buildAndSignTransaction @_ @s @k + mkRwdAcct <- mkRewardAccountBuilder @s @_ @n Nothing + (tx, txMeta, txTime, sealedTx) <- liftHandler $ do + let pwd = coerce $ getApiT $ body ^. #passphrase + W.buildAndSignTransaction @_ @s @k wrk wid era mkRwdAcct pwd txCtx sel' liftHandler $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) mkApiTransaction @@ -3292,23 +3269,22 @@ quitStakePool -> ApiT WalletId -> ApiWalletPassphrase -> Handler (ApiTransaction n) -quitStakePool ctx (ApiT wid) body = - withWorkerCtx ctx wid liftE liftE $ \wrk -> do - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (wdrl, mkRwdAcct) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid (Just SelfWithdrawal) - action <- liftHandler $ W.quitStakePool wrk wid wdrl +quitStakePool ctx (ApiT walletId) body = do + mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (Just SelfWithdrawal) + withWorkerCtx ctx walletId liftE liftE $ \wrk -> do + let db = wrk ^. typed @(DBLayer IO s k) + netLayer = wrk ^. typed @(NetworkLayer IO Block) + (withdrawal, action) <- handleWalletException + $ W.quitStakePool @s @k @n netLayer db walletId ttl <- liftIO $ W.getTxExpiry ti Nothing let txCtx = defaultTransactionCtx - { txWithdrawal = wdrl + { txWithdrawal = withdrawal , txValidityInterval = (Nothing, ttl) , txDelegationAction = Just action } (utxoAvailable, wallet, pendingTxs) <- - liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid + liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk walletId pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) sel <- liftHandler @@ -3325,14 +3301,14 @@ quitStakePool ctx (ApiT wid) body = } $ const Prelude.id sel' <- liftHandler - $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel + $ W.assignChangeAddressesAndUpdateDb wrk walletId genChange sel (tx, txMeta, txTime, sealedTx) <- do let pwd = coerce $ getApiT $ body ^. #passphrase liftHandler $ W.buildAndSignTransaction @_ @s @k - wrk wid era mkRwdAcct pwd txCtx sel' + wrk walletId era mkRwdAcct pwd txCtx sel' liftHandler - $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) - mkApiTransaction ti wrk wid #pendingSince + $ W.submitTx @_ @s @k wrk walletId (tx, txMeta, sealedTx) + mkApiTransaction ti wrk walletId #pendingSince MkApiTransactionParams { txId = tx ^. #txId , txFee = tx ^. #fee @@ -3468,22 +3444,23 @@ createMigrationPlan -> ApiWalletMigrationPlanPostData n -- ^ Target addresses -> Handler (ApiWalletMigrationPlan n) -createMigrationPlan ctx withdrawalType (ApiT wid) postData = do - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (rewardWithdrawal, _) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid withdrawalType - withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do +createMigrationPlan ctx withdrawalType (ApiT wid) postData = + withWorkerCtx ctx wid liftE liftE $ \wrk -> do era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - (wallet, _, _) <- withExceptT ErrCreateMigrationPlanNoSuchWallet $ - W.readWallet wrk wid - plan <- W.createMigrationPlan wrk era wid rewardWithdrawal - failWith ErrCreateMigrationPlanEmpty $ mkApiWalletMigrationPlan - (getState wallet) - (view #addresses postData) - (rewardWithdrawal) - (plan) + rewardWithdrawal <- + maybe (pure NoWithdrawal) (mkWithdrawal @s @_ @n wrk wid era) + withdrawalType + (wallet, _, _) <- liftHandler + $ withExceptT ErrCreateMigrationPlanNoSuchWallet + $ W.readWallet wrk wid + plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal + liftHandler + $ failWith ErrCreateMigrationPlanEmpty + $ mkApiWalletMigrationPlan + (getState wallet) + (view #addresses postData) + (rewardWithdrawal) + (plan) mkApiWalletMigrationPlan :: forall n s. IsOurs s Address @@ -3564,13 +3541,12 @@ migrateWallet -> ApiWalletMigrationPostData n p -> Handler (NonEmpty (ApiTransaction n)) migrateWallet ctx withdrawalType (ApiT wid) postData = do - -- FIXME [ADP-1489] mkRewardAccountBuilder does itself read - -- @currentNodeEra@ which is not guaranteed with the era read here. This - -- could cause problems under exceptional circumstances. - (rewardWithdrawal, mkRewardAccount) <- - mkRewardAccountBuilder @_ @s @_ @n ctx wid withdrawalType + mkRewardAccount <- mkRewardAccountBuilder @s @_ @n withdrawalType withWorkerCtx ctx wid liftE liftE $ \wrk -> do era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + rewardWithdrawal <- + maybe (pure NoWithdrawal) (mkWithdrawal @s @_ @n wrk wid era) + withdrawalType plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal ttl <- liftIO $ W.getTxExpiry ti Nothing pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) @@ -3909,46 +3885,74 @@ type RewardAccountBuilder k = (k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption") -mkRewardAccountBuilder - :: forall ctx s k (n :: NetworkDiscriminant) shelley. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , shelley ~ SeqState n ShelleyKey - , HardDerivation k - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) - , WalletKey k - , Typeable s - , Typeable n - ) - => ctx +mkWithdrawal + :: forall s k (n :: NetworkDiscriminant) + . Typeable s + => Typeable n + => WorkerCtx (ApiLayer s k 'CredFromKeyK) -> WalletId - -> Maybe ApiWithdrawalPostData - -> Handler (Withdrawal, RewardAccountBuilder k) -mkRewardAccountBuilder ctx wid withdrawal = do - let selfRewardCredentials (rootK, pwdP) = - (getRawKey $ deriveRewardAccount @k pwdP rootK, pwdP) + -> AnyCardanoEra + -> ApiWithdrawalPostData + -> Handler Withdrawal +mkWithdrawal workerCtx walletId era apiWdrl = + case apiWdrl of + SelfWithdrawal -> + liftHandler $ mkSelfWithdrawal @s @k @n workerCtx walletId + ExternalWithdrawal mnemonic -> + liftHandler $ mkExternalWithdrawal workerCtx era mnemonic + +mkSelfWithdrawal + :: forall s k (n :: NetworkDiscriminant) + . Typeable s + => Typeable n + => WorkerCtx (ApiLayer s k 'CredFromKeyK) + -> WalletId + -> ExceptT ErrReadRewardAccount IO Withdrawal +mkSelfWithdrawal workerCtx walletId = do + let netLayer = workerCtx ^. networkLayer + db = workerCtx ^. typed @(DBLayer IO s k) + (rewardAccount, _, derivationPath) <- W.readRewardAccount @s @k @n db walletId + withdrawalCoins <- liftIO $ getCachedRewardAccountBalance netLayer rewardAccount + pure $ WithdrawalSelf rewardAccount derivationPath withdrawalCoins + +mkExternalWithdrawal + :: forall s k + . WorkerCtx (ApiLayer s k 'CredFromKeyK) + -> AnyCardanoEra + -> ApiMnemonicT '[15,18,21,24] + -> ExceptT ErrWithdrawalNotWorth IO Withdrawal +mkExternalWithdrawal workerCtx era (ApiMnemonicT mnemonic) = do + let netLayer = workerCtx ^. networkLayer + let (_, rewardAccount, derivationPath) = + W.someRewardAccount @ShelleyKey mnemonic + withdrawalCoins <- liftIO $ do + balance <- getCachedRewardAccountBalance netLayer rewardAccount + W.readNextWithdrawal @_ @k @'CredFromKeyK workerCtx era balance + when (withdrawalCoins == Coin 0) $ throwE ErrWithdrawalNotWorth + pure $ WithdrawalExternal rewardAccount derivationPath withdrawalCoins - withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - case (testEquality (typeRep @s) (typeRep @shelley), withdrawal) of - (Nothing, Just{}) -> - liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet - - (_, Nothing) -> - pure (NoWithdrawal, selfRewardCredentials) - - (Just Refl, Just SelfWithdrawal) -> do - (acct, _, path) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid - wdrl <- liftHandler $ W.queryRewardBalance @_ wrk acct - (, selfRewardCredentials) . WithdrawalSelf acct path - <$> liftIO (W.readNextWithdrawal @_ @k @'CredFromKeyK wrk era wdrl) - - (Just Refl, Just (ExternalWithdrawal (ApiMnemonicT mw))) -> do - let (xprv, acct, path) = W.someRewardAccount @ShelleyKey mw - wdrl <- liftHandler (W.queryRewardBalance @_ wrk acct) - >>= liftIO . W.readNextWithdrawal @_ @k @'CredFromKeyK wrk era - when (wdrl == Coin 0) $ do - liftHandler $ throwE ErrWithdrawalNotWorth - pure (WithdrawalExternal acct path wdrl, const (xprv, mempty)) +mkRewardAccountBuilder + :: forall s k (n :: NetworkDiscriminant) + . ( HardDerivation k + , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) + , WalletKey k + , Typeable s + , Typeable n + ) + => Maybe ApiWithdrawalPostData + -> Handler (RewardAccountBuilder k) +mkRewardAccountBuilder withdrawal = do + let selfRewardCredentials (rootK, pwdP) = + (getRawKey (deriveRewardAccount @k pwdP rootK), pwdP) + case testEquality (typeRep @s) (typeRep @(SeqState n ShelleyKey)) of + Nothing -> liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet + Just {} -> case withdrawal of + Nothing -> pure selfRewardCredentials + Just w -> case w of + SelfWithdrawal -> pure selfRewardCredentials + ExternalWithdrawal (ApiMnemonicT m) -> do + let (xprv, _acct, _path) = W.someRewardAccount @ShelleyKey m + pure (const (xprv, mempty)) -- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'. mkApiCoinSelection From a66f249653c54dc2986c9597d11fae77ea8738e2 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:37:19 +0100 Subject: [PATCH 12/30] refactor: mkApiTransaction uses fields not lenses --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 74 ++++++++----------- 1 file changed, 31 insertions(+), 43 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 b0ba764ed9b..b1bd89c1fb9 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 @@ -542,7 +542,7 @@ import Data.Functor import Data.Functor.Identity ( Identity (..) ) import Data.Generics.Internal.VL.Lens - ( Lens', view, (.~), (^.) ) + ( Lens', set, view, (.~), (^.) ) import Data.Generics.Labels () import Data.Generics.Product @@ -4090,52 +4090,32 @@ mkApiTransaction -> Lens' (ApiTransaction n) (Maybe ApiBlockReference) -> MkApiTransactionParams -> Handler (ApiTransaction n) -mkApiTransaction timeInterpreter wrk wid setTimeReference tx = do - timeRef <- liftIO $ (#time .~ (tx ^. #txTime)) <$> makeApiBlockReference - (neverFails - "makeApiBlockReference shouldn't fail getting the time of \ - \transactions with slots in the past" timeInterpreter) - (tx ^. (#txMeta . #slotNo)) - (natural (tx ^. (#txMeta . #blockHeight))) - expRef <- liftIO $ - traverse makeApiSlotReference' (tx ^. (#txMeta . #expiry)) - +mkApiTransaction timeInterpreter wrk wid timeRefLens tx = do + timeRef <- liftIO $ (#time .~ tx ^. #txTime) <$> makeApiBlockReference + (neverFails + "makeApiBlockReference shouldn't fail getting the time of \ + \transactions with slots in the past" timeInterpreter) + (tx ^. #txMeta . #slotNo) + (natural (tx ^. #txMeta . #blockHeight)) + expRef <- liftIO $ traverse makeApiSlotReference' (tx ^. #txMeta . #expiry) parsedValues <- traverse parseTxCBOR $ tx ^. #txCBOR parsedCertificates <- if hasDelegation (Proxy @s) then traverse (getApiAnyCertificates wrk wid) parsedValues else pure Nothing parsedMintBurn <- forM parsedValues $ getTxApiAssetMintBurn @_ @s @k @n wrk wid - let parsedValidity = view #validityInterval =<< parsedValues - parsedIntegrity = view #scriptIntegrity =<< parsedValues - parsedExtraSigs = view #extraSignatures <$> parsedValues - - return $ apiTx - & setTimeReference .~ Just timeRef - & #expiresAt .~ expRef - & #certificates .~ fromMaybe [] parsedCertificates - & #mint .~ maybe noApiAsset fst parsedMintBurn - & #burn .~ maybe noApiAsset snd parsedMintBurn - & #validityInterval .~ fmap ApiValidityIntervalExplicit parsedValidity - & #scriptIntegrity .~ (ApiT <$> parsedIntegrity) - & #extraSignatures .~ maybe [] (fmap ApiT) parsedExtraSigs - where - -- Since tx expiry can be far in the future, we use unsafeExtendSafeZone for - -- now. - makeApiSlotReference' = makeApiSlotReference - $ unsafeExtendSafeZone timeInterpreter - apiTx :: ApiTransaction n - apiTx = ApiTransaction + + pure $ set timeRefLens (Just timeRef) $ ApiTransaction { id = ApiT $ tx ^. #txId - , amount = Quantity . fromIntegral $ tx ^. (#txMeta . #amount . #unCoin) + , amount = Quantity . fromIntegral $ tx ^. #txMeta . #amount . #unCoin , fee = Quantity $ maybe 0 (fromIntegral . unCoin) (tx ^. #txFee) , depositTaken = Quantity depositIfAny , depositReturned = Quantity reclaimIfAny , insertedAt = Nothing , pendingSince = Nothing - , expiresAt = Nothing + , expiresAt = expRef , depth = Nothing - , direction = ApiT (tx ^. (#txMeta . #direction)) + , direction = ApiT (tx ^. #txMeta . #direction) , inputs = [ ApiTxInput (toAddressAmount @n <$> o) (ApiT i) | (i, o) <- tx ^. #txInputs @@ -4149,17 +4129,25 @@ mkApiTransaction timeInterpreter wrk wid setTimeReference tx = do toAddressAmount @n <$> tx ^. #txCollateralOutput , withdrawals = mkApiWithdrawal @n <$> Map.toList (tx ^. #txWithdrawals) , status = ApiT (tx ^. #txMeta . #status) - , metadata = TxMetadataWithSchema (tx ^. #txMetadataSchema) - <$> tx ^. #txMetadata + , metadata = + TxMetadataWithSchema (tx ^. #txMetadataSchema) <$> tx ^. #txMetadata , scriptValidity = ApiT <$> tx ^. #txScriptValidity - , certificates = [] - , mint = ApiAssetMintBurn [] Nothing Nothing - , burn = ApiAssetMintBurn [] Nothing Nothing - , validityInterval = Nothing - , scriptIntegrity = Nothing - , extraSignatures = [] + , certificates = fromMaybe [] parsedCertificates + , mint = maybe noApiAsset fst parsedMintBurn + , burn = maybe noApiAsset snd parsedMintBurn + , validityInterval = + ApiValidityIntervalExplicit + <$> (view #validityInterval =<< parsedValues) + , scriptIntegrity = + ApiT <$> (view #scriptIntegrity =<< parsedValues) + , extraSignatures = + ApiT <$> (view #extraSignatures =<< maybe [] pure parsedValues) } - + where + -- Since tx expiry can be far in the future, we use unsafeExtendSafeZone for + -- now. + makeApiSlotReference' = makeApiSlotReference + $ unsafeExtendSafeZone timeInterpreter depositIfAny :: Natural depositIfAny | tx ^. (#txMeta . #direction) == W.Outgoing = From 83d4162c546f5cb14e9369f1ba0ca4f88e7a53a1 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 12:39:11 +0100 Subject: [PATCH 13/30] refactor: quitStakePool renamed to validatedQuitStakePoolAction --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 4 +- lib/wallet/src/Cardano/Wallet.hs | 48 +++++++++++-------- 2 files changed, 31 insertions(+), 21 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 b1bd89c1fb9..98dd53d16b0 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 @@ -2330,8 +2330,8 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do @_ @s @k wrk curEpoch pools pid poolStatus wid pure (del, act, Nothing) [(Leaving _)] -> do - del <- liftHandler $ - W.quitStakePool @_ @s @k wrk wid wdrl + del <- handleWalletException $ + W.validatedQuitStakePoolAction @s @k db wid wdrl pure (del, Nothing, Just $ W.stakeKeyDeposit pp) _ -> liftHandler $ diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index d3db8b61f0b..49a94863ea0 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -150,6 +150,7 @@ module Cardano.Wallet , PoolRetirementEpochInfo (..) , joinStakePool , quitStakePool + , validatedQuitStakePoolAction , guardJoin , guardQuit , ErrStakePoolDelegation (..) @@ -3075,28 +3076,37 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid = nl = ctx ^. networkLayer -- | Helper function to factor necessary logic for quitting a stake pool. -quitStakePool - :: forall ctx s k - . HasDBLayer IO s k ctx - => ctx +validatedQuitStakePoolAction + :: forall s k. DBLayer IO s k -> WalletId -> Withdrawal - -> ExceptT ErrStakePoolDelegation IO DelegationAction -quitStakePool ctx wid wdrl = db & \DBLayer{..} -> do - (_ , walDelegation) <- mapExceptT atomically - $ withExceptT ErrStakePoolDelegationNoSuchWallet - $ withNoSuchWallet wid - $ readWalletMeta wid - - rewards <- liftIO - $ fetchRewardBalance @ctx @s @k ctx wid - - withExceptT ErrStakePoolQuit $ except $ - guardQuit walDelegation wdrl rewards + -> IO DelegationAction +validatedQuitStakePoolAction db walletId withdrawal = db & \DBLayer{..} -> do + (_, delegation) <- atomically (readWalletMeta walletId) + >>= maybe + (throw (ExceptionStakePoolDelegation + (ErrStakePoolDelegationNoSuchWallet + (ErrNoSuchWallet walletId)))) + pure + rewards <- liftIO $ fetchRewardBalance @s @k db walletId + Quit <$ + either (throw . ExceptionStakePoolDelegation . ErrStakePoolQuit) pure + (guardQuit delegation withdrawal rewards) - pure Quit - where - db = ctx ^. dbLayer @IO @s @k +quitStakePool + :: forall s k (n :: NetworkDiscriminant) + . (Typeable s, Typeable n) + => NetworkLayer IO Block + -> DBLayer IO s k + -> WalletId + -> IO (Withdrawal, DelegationAction) +quitStakePool netLayer db walletId = do + (rewardAccount, _, derivationPath) <- + runExceptT (readRewardAccount @s @k @n db walletId) + >>= either (throw . ExceptionReadRewardAccount) pure + withdrawal <- WithdrawalSelf rewardAccount derivationPath + <$> getCachedRewardAccountBalance netLayer rewardAccount + (withdrawal,) <$> validatedQuitStakePoolAction db walletId withdrawal {------------------------------------------------------------------------------- Fee Estimation From df898b2a220f9b7dcf6ead88c854d4f453d23483 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 17:58:47 +0100 Subject: [PATCH 14/30] refactor: rename getTxExpiry to transactionExpirySlot --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 16 ++++++++-------- lib/wallet/src/Cardano/Wallet.hs | 17 ++++++++--------- 2 files changed, 16 insertions(+), 17 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 98dd53d16b0..7cd56ebdcf8 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 @@ -1993,7 +1993,7 @@ postTransactionOld ctx genChange (ApiT wid) body = do mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (body ^. #withdrawal) withWorkerCtx ctx wid liftE liftE $ \wrk -> do era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - ttl <- liftIO $ W.getTxExpiry ti mTTL + ttl <- liftIO $ W.transactionExpirySlot ti mTTL wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl @@ -2507,11 +2507,11 @@ decodeValidityInterval ti validityInterval = do Left ApiValidityBoundUnspecified -> pure $ SlotNo 0 Right ApiValidityBoundUnspecified -> - W.getTxExpiry ti Nothing + W.transactionExpirySlot ti Nothing Right (ApiValidityBoundAsTimeFromNow (Quantity sec)) -> - W.getTxExpiry ti (Just sec) + W.transactionExpirySlot ti (Just sec) Left (ApiValidityBoundAsTimeFromNow (Quantity sec)) -> - W.getTxExpiry ti (Just sec) + W.transactionExpirySlot ti (Just sec) Right (ApiValidityBoundAsSlot (Quantity slot)) -> pure $ SlotNo slot Left (ApiValidityBoundAsSlot (Quantity slot)) -> @@ -2944,7 +2944,7 @@ submitTransaction -> Handler ApiTxId submitTransaction ctx apiw@(ApiT wid) apitx = do --TODO: revisit/possibly set proper ttls in ADP-1193 - ttl <- liftIO $ W.getTxExpiry ti Nothing + ttl <- liftIO $ W.transactionExpirySlot ti Nothing era <- liftIO $ NW.currentNodeEra nl let sealedTx = getApiT . (view #serialisedTxSealed) $ apitx @@ -3074,7 +3074,7 @@ submitSharedTransaction -> ApiSerialisedTransaction -> Handler ApiTxId submitSharedTransaction ctx apiw@(ApiT wid) apitx = do - ttl <- liftIO $ W.getTxExpiry ti Nothing + ttl <- liftIO $ W.transactionExpirySlot ti Nothing era <- liftIO $ NW.currentNodeEra nl let sealedTx = getApiT . (view #serialisedTxSealed) $ apitx @@ -3153,7 +3153,7 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do (action, _) <- liftHandler $ W.joinStakePool @_ @s @k wrk curEpoch pools poolId poolStatus wid - ttl <- liftIO $ W.getTxExpiry ti Nothing + ttl <- liftIO $ W.transactionExpirySlot ti Nothing let txCtx = defaultTransactionCtx { txWithdrawal = NoWithdrawal , txValidityInterval = (Nothing, ttl) @@ -3548,7 +3548,7 @@ migrateWallet ctx withdrawalType (ApiT wid) postData = do maybe (pure NoWithdrawal) (mkWithdrawal @s @_ @n wrk wid era) withdrawalType plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal - ttl <- liftIO $ W.getTxExpiry ti Nothing + ttl <- liftIO $ W.transactionExpirySlot ti Nothing pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) selectionWithdrawals <- liftHandler $ failWith ErrCreateMigrationPlanEmpty diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 49a94863ea0..2efc33d90e5 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -116,7 +116,7 @@ module Cardano.Wallet , ErrDecodeTx (..) -- ** Payment - , getTxExpiry + , transactionExpirySlot , SelectAssetsParams (..) , selectAssets , readWalletUTxOIndex @@ -2558,20 +2558,19 @@ constructSharedTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do -- -- If no TTL is provided, a default of 2 hours is used (note: there is no -- particular reason why we chose that duration). -getTxExpiry +transactionExpirySlot :: TimeInterpreter (ExceptT PastHorizonException IO) -- ^ Context for time to slot calculation. -> Maybe NominalDiffTime -- ^ Time to live (TTL) in seconds from now. -> IO SlotNo -getTxExpiry ti maybeTTL = do - expTime <- addRelTime ttl <$> currentRelativeTime (unsafeExtendSafeZone ti) - interpretQuery (unsafeExtendSafeZone ti) $ ceilingSlotAt expTime +transactionExpirySlot safeTimeInterpreter maybeTTL = + interpretQuery timeInterpreter . ceilingSlotAt . addRelTime ttl + =<< currentRelativeTime timeInterpreter where - ttl = fromMaybe defaultTTL maybeTTL - - defaultTTL :: NominalDiffTime - defaultTTL = 7200 -- that's 2 hours + timeInterpreter = unsafeExtendSafeZone safeTimeInterpreter + ttl :: NominalDiffTime = fromMaybe defaultTTL maybeTTL + defaultTTL :: NominalDiffTime = 7200 -- that's 2 hours constructTxMeta :: forall ctx s k. From 5c7b6202e71c311a77e7967ff0c3f57889245268 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 1 Nov 2022 18:00:13 +0100 Subject: [PATCH 15/30] refactor: quitStakePool builds TransactionCtx --- .../http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 14 +++++--------- lib/wallet/src/Cardano/Wallet.hs | 13 ++++++++++--- 2 files changed, 15 insertions(+), 12 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 7cd56ebdcf8..6c3f47f7c3b 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 @@ -3264,7 +3264,9 @@ quitStakePool , Typeable s , WalletKey k , AddressBookIso s - , BoundedAddressLength k, HasDelegation s) + , BoundedAddressLength k + , HasDelegation s + ) => ctx -> ApiT WalletId -> ApiWalletPassphrase @@ -3274,14 +3276,8 @@ quitStakePool ctx (ApiT walletId) body = do withWorkerCtx ctx walletId liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO s k) netLayer = wrk ^. typed @(NetworkLayer IO Block) - (withdrawal, action) <- handleWalletException - $ W.quitStakePool @s @k @n netLayer db walletId - ttl <- liftIO $ W.getTxExpiry ti Nothing - let txCtx = defaultTransactionCtx - { txWithdrawal = withdrawal - , txValidityInterval = (Nothing, ttl) - , txDelegationAction = Just action - } + txCtx <- handleWalletException + $ W.quitStakePool @s @k @n netLayer db ti walletId (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk walletId diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 2efc33d90e5..5ea40bfdb87 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -3097,15 +3097,22 @@ quitStakePool . (Typeable s, Typeable n) => NetworkLayer IO Block -> DBLayer IO s k + -> TimeInterpreter (ExceptT PastHorizonException IO) -> WalletId - -> IO (Withdrawal, DelegationAction) -quitStakePool netLayer db walletId = do + -> IO TransactionCtx +quitStakePool netLayer db timeInterpreter walletId = do (rewardAccount, _, derivationPath) <- runExceptT (readRewardAccount @s @k @n db walletId) >>= either (throw . ExceptionReadRewardAccount) pure withdrawal <- WithdrawalSelf rewardAccount derivationPath <$> getCachedRewardAccountBalance netLayer rewardAccount - (withdrawal,) <$> validatedQuitStakePoolAction db walletId withdrawal + action <- validatedQuitStakePoolAction db walletId withdrawal + ttl <- transactionExpirySlot timeInterpreter Nothing + pure defaultTransactionCtx + { txWithdrawal = withdrawal + , txValidityInterval = (Nothing, ttl) + , txDelegationAction = Just action + } {------------------------------------------------------------------------------- Fee Estimation From d878465e8d8c3b4e25bdd1a526dab9a656262e42 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Thu, 3 Nov 2022 13:55:47 +0100 Subject: [PATCH 16/30] Use Refl instead of an irrefutable pattern. --- lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 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 6c3f47f7c3b..07f81c219e3 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 @@ -577,7 +577,7 @@ import Data.Text.Class import Data.Time ( UTCTime ) import Data.Type.Equality - ( type (==), testEquality ) + ( type (==), testEquality,type (:~:) (..) ) import Data.Word ( Word32 ) import Fmt @@ -3942,7 +3942,7 @@ mkRewardAccountBuilder withdrawal = do (getRawKey (deriveRewardAccount @k pwdP rootK), pwdP) case testEquality (typeRep @s) (typeRep @(SeqState n ShelleyKey)) of Nothing -> liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet - Just {} -> case withdrawal of + Just Refl -> case withdrawal of Nothing -> pure selfRewardCredentials Just w -> case w of SelfWithdrawal -> pure selfRewardCredentials From d4c67eb9eff15e0c1eded1eefb9d74f224fe9809 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Thu, 3 Nov 2022 15:34:57 +0100 Subject: [PATCH 17/30] remove unnecessary polymorphism --- lib/wallet/api/http/Cardano/Wallet/Api.hs | 19 +- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 194 +++++++++--------- lib/wallet/src/Cardano/Wallet.hs | 39 ++-- 3 files changed, 119 insertions(+), 133 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api.hs b/lib/wallet/api/http/Cardano/Wallet/Api.hs index 3e7489ce7d0..dc12ea6a372 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api.hs @@ -1164,15 +1164,16 @@ type PostExternalTransaction = "proxy" data ApiLayer s (k :: Depth -> Type -> Type) ktype = ApiLayer - (Tracer IO TxSubmitLog) - (Tracer IO (WorkerLog WalletId WalletWorkerLog)) - (Block, NetworkParameters) - (NetworkLayer IO Block) - (TransactionLayer k ktype SealedTx) - (DBFactory IO s k) - (WorkerRegistry WalletId (DBLayer IO s k)) - (Concierge IO WalletLock) - (TokenMetadataClient IO) + { tracerTxSubmit :: Tracer IO TxSubmitLog + , tracerWalletWorker :: Tracer IO (WorkerLog WalletId WalletWorkerLog) + , netParams :: (Block, NetworkParameters) + , netLayer :: NetworkLayer IO Block + , txLayer :: TransactionLayer k ktype SealedTx + , _dbFactory :: DBFactory IO s k + , _workerRegistry :: WorkerRegistry WalletId (DBLayer IO s k) + , concierge :: Concierge IO WalletLock + , _tokenMetadataClient :: TokenMetadataClient IO + } deriving (Generic) -- | Locks that are held by the wallet in order to enforce 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 07f81c219e3..896dadc5b82 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 @@ -15,6 +15,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Copyright: © 2018-2020 IOHK @@ -174,6 +175,7 @@ import Cardano.Wallet , TxSubmitLog , genesisData , manageRewardBalance + , dbLayer , networkLayer ) import Cardano.Wallet.Address.Book @@ -871,13 +873,13 @@ mkShelleyWallet , HasWorkerRegistry s k ctx ) => MkApiWallet ctx s ApiWallet -mkShelleyWallet ctx wid cp meta delegation pending progress = do +mkShelleyWallet ctx@ApiLayer{..} wid cp meta delegation pending progress = do reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer -- never fails - returns zero if balance not found liftIO $ W.fetchRewardBalance @s @k db wid - let ti = timeInterpreter $ ctx ^. networkLayer + let ti = timeInterpreter netLayer -- In the Shelley era of Byron;Shelley;Allegra toApiWalletDelegation using -- an unextended @ti@ will simply fail because of uncertainty about the next @@ -1063,7 +1065,8 @@ mkSharedWallet , Shared.SupportsDiscovery n k ) => MkApiWallet ctx s ApiSharedWallet -mkSharedWallet ctx wid cp meta delegation pending progress = case Shared.ready st of +mkSharedWallet ctx@ApiLayer{..} wid cp meta delegation pending progress = + case Shared.ready st of Shared.Pending -> pure $ ApiSharedWallet $ Left $ ApiPendingSharedWallet { id = ApiT wid , name = ApiT $ meta ^. #name @@ -1074,7 +1077,7 @@ mkSharedWallet ctx wid cp meta delegation pending progress = case Shared.ready s } Shared.Active _ -> do reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer -- never fails - returns zero if balance not found liftIO $ W.fetchRewardBalance @s @k db wid @@ -1607,26 +1610,27 @@ getWalletUtxoSnapshot ctx (ApiT wid) = do -------------------------------------------------------------------------------} selectCoins - :: forall ctx s k n. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , IsOurs s Address + :: forall s k n. + ( IsOurs s Address , GenChange s , Typeable n , Typeable s , BoundedAddressLength k ) - => ctx + => ApiLayer s k 'CredFromKeyK -> ArgGenChange s -> ApiT WalletId -> ApiSelectCoinsPayments n -> Handler (ApiCoinSelection n) -selectCoins ctx genChange (ApiT wid) body = do +selectCoins ctx@ApiLayer {..} genChange (ApiT wid) body = do let md = body ^? #metadata . traverse . #getApiT withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal - Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl + Just apiWdrl -> + mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl let outs = addressAmountToTxOut <$> body ^. #payments let txCtx = defaultTransactionCtx { txWithdrawal = wdrl @@ -1704,7 +1708,7 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler - $ W.readRewardAccount @s @k @n (wrk ^. typed @(DBLayer IO s k)) wid + $ W.readRewardAccount @s @k @n (wrk ^. dbLayer) wid let deposits = maybeToList deposit @@ -1723,7 +1727,8 @@ selectCoinsForQuit selectCoinsForQuit ctx (ApiT wid) = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO (SeqState n k) k) - wdrl <- liftHandler $ mkSelfWithdrawal @_ @k @n wrk wid + let netLayer = wrk ^. networkLayer + wdrl <- liftHandler $ mkSelfWithdrawal @_ @k @n netLayer db wid action <- handleWalletException $ W.validatedQuitStakePoolAction @(SeqState n k) @k db wid wdrl @@ -1737,9 +1742,6 @@ selectCoinsForQuit ctx (ApiT wid) = do & uncurry (W.selectionToUnsignedTx (txWithdrawal txCtx)) (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @(SeqState n k) @k wrk wid - pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) - let refund = W.stakeKeyDeposit pp let selectAssetsParams = W.SelectAssetsParams { outputs = [] , pendingTxs @@ -1750,12 +1752,14 @@ selectCoinsForQuit ctx (ApiT wid) = do , wallet , selectionStrategy = SelectionStrategyOptimal } - utx <- liftHandler - $ W.selectAssets @_ @_ @(SeqState n k) @k @'CredFromKeyK + pp <- liftIO $ NW.currentProtocolParameters netLayer + utx <- liftHandler $ do + era <- liftIO $ NW.currentNodeEra netLayer + W.selectAssets @_ @_ @(SeqState n k) @k @'CredFromKeyK wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler $ W.readRewardAccount @(SeqState n k) @k @n db wid - + let refund = W.stakeKeyDeposit pp pure $ mkApiCoinSelection [] [refund] (Just (action, path)) Nothing utx {------------------------------------------------------------------------------- @@ -1984,7 +1988,7 @@ postTransactionOld -> ApiT WalletId -> PostTransactionOldData n -> Handler (ApiTransaction n) -postTransactionOld ctx genChange (ApiT wid) body = do +postTransactionOld ctx@ApiLayer{..} genChange (ApiT wid) body = do let pwd = coerce $ body ^. #passphrase . #getApiT let outs = addressAmountToTxOut <$> body ^. #payments let md = body ^? #metadata . traverse . #txMetadataWithSchema_metadata @@ -1992,11 +1996,13 @@ postTransactionOld ctx genChange (ApiT wid) body = do mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (body ^. #withdrawal) withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + era <- liftIO $ NW.currentNodeEra netLayer ttl <- liftIO $ W.transactionExpirySlot ti mTTL wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal - Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl + Just apiWdrl -> + mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl , txMetadata = md @@ -2006,7 +2012,6 @@ postTransactionOld ctx genChange (ApiT wid) body = do (ctx ^. walletLocks) (PostTransactionOld wid) $ do (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid - pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) let selectAssetsParams = W.SelectAssetsParams { outputs = F.toList outs , pendingTxs @@ -2019,6 +2024,7 @@ postTransactionOld ctx genChange (ApiT wid) body = do , wallet , selectionStrategy = SelectionStrategyOptimal } + pp <- liftIO $ NW.currentProtocolParameters netLayer sel <- liftHandler $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams @@ -2032,7 +2038,7 @@ postTransactionOld ctx genChange (ApiT wid) body = do $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) pure (sel, tx, txMeta, txTime, pp) mkApiTransaction - (timeInterpreter $ ctx ^. networkLayer) + (timeInterpreter netLayer) wrk wid #pendingSince $ MkApiTransactionParams @@ -2174,12 +2180,14 @@ postTransactionFeeOld -> ApiT WalletId -> PostTransactionFeeOldData n -> Handler ApiFee -postTransactionFeeOld ctx (ApiT wid) body = +postTransactionFeeOld ctx@ApiLayer{..} (ApiT wid) body = withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal - Just apiWdrl -> mkWithdrawal @s @_ @n wrk wid era apiWdrl + Just apiWdrl -> + mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl , txMetadata = body @@ -2188,7 +2196,7 @@ postTransactionFeeOld ctx (ApiT wid) body = (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid let outs = addressAmountToTxOut <$> body ^. #payments - pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) + pp <- liftIO $ NW.currentProtocolParameters netLayer let getFee = const (selectionDelta TokenBundle.getCoin) let selectAssetsParams = W.SelectAssetsParams { outputs = F.toList outs @@ -2304,11 +2312,13 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do $ throwE ErrConstructTxValidityIntervalNotWithinScriptTimelock withWorkerCtx ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) - pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + netLayer = wrk ^. networkLayer + pp <- liftIO $ NW.currentProtocolParameters netLayer + era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of - Just SelfWithdraw -> liftHandler $ mkSelfWithdrawal @_ @k @n wrk wid + Just SelfWithdraw -> liftHandler + $ mkSelfWithdrawal @_ @k @n netLayer db wid _ -> pure NoWithdrawal (deposit, refund, txCtx) <- case body ^. #delegations of Nothing -> pure (Nothing, Nothing, defaultTransactionCtx @@ -2719,18 +2729,14 @@ decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _ } balanceTransaction - :: forall ctx s k (n :: NetworkDiscriminant). - ( ctx ~ ApiLayer s k 'CredFromKeyK - , HasNetworkLayer IO ctx - , GenChange s - , BoundedAddressLength k - ) - => ctx + :: forall s k (n :: NetworkDiscriminant) + . (GenChange s, BoundedAddressLength k) + => ApiLayer s k 'CredFromKeyK -> ArgGenChange s -> ApiT WalletId -> ApiBalanceTransactionPostData n -> Handler ApiSerialisedTransaction -balanceTransaction ctx genChange (ApiT wid) body = do +balanceTransaction ctx@ApiLayer{..} genChange (ApiT wid) body = do -- NOTE: Ideally we'd read @pp@ and @era@ atomically. pp <- liftIO $ NW.currentProtocolParameters nl -- TODO: This throws when still in the Byron era. @@ -2738,7 +2744,7 @@ balanceTransaction ctx genChange (ApiT wid) body = do let nodePParams = fromJust $ W.currentNodeProtocolParameters pp withWorkerCtx ctx wid liftE liftE $ \wrk -> do wallet <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid - ti <- liftIO $ snapshot $ timeInterpreter $ ctx ^. networkLayer + ti <- liftIO $ snapshot $ timeInterpreter netLayer let mkPartialTx :: forall era. WriteTx.IsRecentEra era => Cardano.Tx era @@ -2846,7 +2852,7 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do , scriptValidity } = decodedTx withWorkerCtx ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer (acct, _, acctPath) <- liftHandler $ W.readRewardAccount @s @k @n db wid inputPaths <- @@ -2983,7 +2989,7 @@ submitTransaction ctx apiw@(ApiT wid) apitx = do ErrSubmitTransactionPartiallySignedOrNoSignedTx witsRequiredForInputs totalNumberOfWits _ <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer (acct, _, path) <- liftHandler $ W.readRewardAccount @s @k @n db wid let wdrl = getOurWdrl acct path apiDecoded let txCtx = defaultTransactionCtx @@ -3274,7 +3280,7 @@ quitStakePool quitStakePool ctx (ApiT walletId) body = do mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (Just SelfWithdrawal) withWorkerCtx ctx walletId liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer netLayer = wrk ^. typed @(NetworkLayer IO Block) txCtx <- handleWalletException $ W.quitStakePool @s @k @n netLayer db ti walletId @@ -3392,20 +3398,15 @@ listStakeKeys' utxo lookupStakeRef fetchRewards ourKeysWithInfo = do } listStakeKeys - :: forall ctx s n k. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , s ~ SeqState n k - , HasNetworkLayer IO ctx - , Typeable n - , Typeable s - ) + :: forall s n k + . (Typeable s, Typeable n) => (Address -> Maybe RewardAccount) - -> ctx + -> ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> Handler (ApiStakeKeys n) -listStakeKeys lookupStakeRef ctx (ApiT wid) = do +listStakeKeys lookupStakeRef ctx@ApiLayer{..} (ApiT wid) = withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do - let db = wrk ^. typed @(DBLayer IO s k) + let db = wrk ^. dbLayer (wal, (_, delegation) ,pending) <- W.readWallet @_ @s @k wrk wid let utxo = availableUTxO @s pending wal @@ -3421,10 +3422,8 @@ listStakeKeys lookupStakeRef ctx (ApiT wid) = do liftIO $ listStakeKeys' @n utxo lookupStakeRef - (fetchRewardAccountBalances nl) + (fetchRewardAccountBalances netLayer) ourKeys - where - nl = ctx ^. networkLayer {------------------------------------------------------------------------------- Migrations @@ -3440,11 +3439,14 @@ createMigrationPlan -> ApiWalletMigrationPlanPostData n -- ^ Target addresses -> Handler (ApiWalletMigrationPlan n) -createMigrationPlan ctx withdrawalType (ApiT wid) postData = +createMigrationPlan ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + era <- liftIO $ NW.currentNodeEra netLayer rewardWithdrawal <- - maybe (pure NoWithdrawal) (mkWithdrawal @s @_ @n wrk wid era) + maybe + (pure NoWithdrawal) + (mkWithdrawal @s @_ @n netLayer txLayer db wid era) withdrawalType (wallet, _, _) <- liftHandler $ withExceptT ErrCreateMigrationPlanNoSuchWallet @@ -3519,33 +3521,34 @@ mkApiWalletMigrationPlan s addresses rewardWithdrawal plan = } migrateWallet - :: forall ctx s k n p. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) + :: forall s k n p. + ( Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) , HardDerivation k - , HasNetworkLayer IO ctx , IsOwned s k 'CredFromKeyK , Typeable n , Typeable s , WalletKey k , HasDelegation s ) - => ctx + => ApiLayer s k 'CredFromKeyK -> Maybe ApiWithdrawalPostData -- ^ What type of reward withdrawal to attempt -> ApiT WalletId -> ApiWalletMigrationPostData n p -> Handler (NonEmpty (ApiTransaction n)) -migrateWallet ctx withdrawalType (ApiT wid) postData = do +migrateWallet ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = do mkRewardAccount <- mkRewardAccountBuilder @s @_ @n withdrawalType withWorkerCtx ctx wid liftE liftE $ \wrk -> do - era <- liftIO $ NW.currentNodeEra (wrk ^. networkLayer) + let db = wrk ^. dbLayer + era <- liftIO $ NW.currentNodeEra netLayer rewardWithdrawal <- - maybe (pure NoWithdrawal) (mkWithdrawal @s @_ @n wrk wid era) + maybe + (pure NoWithdrawal) + (mkWithdrawal @s @_ @n netLayer txLayer db wid era) withdrawalType plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal ttl <- liftIO $ W.transactionExpirySlot ti Nothing - pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) + pp <- liftIO $ NW.currentProtocolParameters netLayer selectionWithdrawals <- liftHandler $ failWith ErrCreateMigrationPlanEmpty $ W.migrationPlanToSelectionWithdrawals @@ -3567,7 +3570,7 @@ migrateWallet ctx withdrawalType (ApiT wid) postData = do liftHandler $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) mkApiTransaction - (timeInterpreter (ctx ^. networkLayer)) + (timeInterpreter netLayer) wrk wid #pendingSince MkApiTransactionParams @@ -3882,48 +3885,45 @@ type RewardAccountBuilder k -> (XPrv, Passphrase "encryption") mkWithdrawal - :: forall s k (n :: NetworkDiscriminant) - . Typeable s - => Typeable n - => WorkerCtx (ApiLayer s k 'CredFromKeyK) + :: forall s k (n :: NetworkDiscriminant) ktype tx + . (Typeable s, Typeable n) + => NetworkLayer IO Block + -> TransactionLayer k ktype tx + -> DBLayer IO s k -> WalletId -> AnyCardanoEra -> ApiWithdrawalPostData -> Handler Withdrawal -mkWithdrawal workerCtx walletId era apiWdrl = - case apiWdrl of - SelfWithdrawal -> - liftHandler $ mkSelfWithdrawal @s @k @n workerCtx walletId - ExternalWithdrawal mnemonic -> - liftHandler $ mkExternalWithdrawal workerCtx era mnemonic +mkWithdrawal netLayer txLayer db wallet era = \case + SelfWithdrawal -> + liftHandler $ mkSelfWithdrawal @s @k @n netLayer db wallet + ExternalWithdrawal mnemonic -> + liftHandler $ mkExternalWithdrawal netLayer txLayer era mnemonic mkSelfWithdrawal - :: forall s k (n :: NetworkDiscriminant) - . Typeable s - => Typeable n - => WorkerCtx (ApiLayer s k 'CredFromKeyK) + :: forall s k (n :: NetworkDiscriminant). (Typeable s, Typeable n) + => NetworkLayer IO Block + -> DBLayer IO s k -> WalletId -> ExceptT ErrReadRewardAccount IO Withdrawal -mkSelfWithdrawal workerCtx walletId = do - let netLayer = workerCtx ^. networkLayer - db = workerCtx ^. typed @(DBLayer IO s k) - (rewardAccount, _, derivationPath) <- W.readRewardAccount @s @k @n db walletId - withdrawalCoins <- liftIO $ getCachedRewardAccountBalance netLayer rewardAccount - pure $ WithdrawalSelf rewardAccount derivationPath withdrawalCoins +mkSelfWithdrawal netLayer db wallet = do + (rewardAccount, _, derivationPath) <- W.readRewardAccount @s @k @n db wallet + liftIO $ WithdrawalSelf rewardAccount derivationPath <$> + getCachedRewardAccountBalance netLayer rewardAccount mkExternalWithdrawal - :: forall s k - . WorkerCtx (ApiLayer s k 'CredFromKeyK) + :: forall k ktype tx + . NetworkLayer IO Block + -> TransactionLayer k ktype tx -> AnyCardanoEra -> ApiMnemonicT '[15,18,21,24] -> ExceptT ErrWithdrawalNotWorth IO Withdrawal -mkExternalWithdrawal workerCtx era (ApiMnemonicT mnemonic) = do - let netLayer = workerCtx ^. networkLayer +mkExternalWithdrawal netLayer txLayer era (ApiMnemonicT mnemonic) = do let (_, rewardAccount, derivationPath) = W.someRewardAccount @ShelleyKey mnemonic withdrawalCoins <- liftIO $ do balance <- getCachedRewardAccountBalance netLayer rewardAccount - W.readNextWithdrawal @_ @k @'CredFromKeyK workerCtx era balance + W.readNextWithdrawal netLayer txLayer era balance when (withdrawalCoins == Coin 0) $ throwE ErrWithdrawalNotWorth pure $ WithdrawalExternal rewardAccount derivationPath withdrawalCoins @@ -4357,7 +4357,7 @@ startWalletWorker startWalletWorker ctx coworker = void . registerWorker ctx before coworker where before ctx' wid = - W.checkWalletIntegrity (ctx' ^. typed @(DBLayer IO s k)) wid gp + W.checkWalletIntegrity (ctx' ^. dbLayer) wid gp (_, NetworkParameters gp _ _) = ctx ^. genesisData -- | Register a wallet create and restore thread with the worker registry. diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 5ea40bfdb87..7f7ebcd7374 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1207,41 +1207,26 @@ fetchRewardBalance db wid = db & \DBLayer{..} -> -- b) The current reward value is too small to be considered (adding it would -- cost more than its value). readNextWithdrawal - :: forall ctx k ktype. - ( HasTransactionLayer k ktype ctx - , HasNetworkLayer IO ctx - ) - => ctx + :: forall k ktype tx + . NetworkLayer IO Block + -> TransactionLayer k ktype tx -> Cardano.AnyCardanoEra -> Coin -> IO Coin -readNextWithdrawal ctx era (Coin withdrawal) = do - pp <- currentProtocolParameters nl - - let costWith = - calcMinimumCost tl era pp (mkTxCtx $ Coin withdrawal) emptySkeleton - - let costWithout = - calcMinimumCost tl era pp (mkTxCtx $ Coin 0) emptySkeleton - - let costOfWithdrawal = - Coin.toInteger costWith - Coin.toInteger costWithout - +readNextWithdrawal netLayer txLayer era (Coin withdrawal) = do + pp <- currentProtocolParameters netLayer + let minimumCost txCtx = calcMinimumCost txLayer era pp txCtx emptySkeleton + costWith = minimumCost $ mkTxCtx $ Coin withdrawal + costWithout = minimumCost $ mkTxCtx $ Coin 0 + costOfWithdrawal = Coin.toInteger costWith - Coin.toInteger costWithout pure . Coin $ - if toInteger withdrawal < 2 * costOfWithdrawal - then 0 - else withdrawal + if toInteger withdrawal < 2 * costOfWithdrawal then 0 else withdrawal where - tl = ctx ^. transactionLayer @k @ktype - nl = ctx ^. networkLayer - mkTxCtx wdrl = defaultTransactionCtx { txWithdrawal = WithdrawalSelf dummyAcct dummyPath wdrl } where - dummyAcct = - RewardAccount mempty - dummyPath = - DerivationIndex 0 :| [] + dummyAcct = RewardAccount mempty + dummyPath = DerivationIndex 0 :| [] readRewardAccount :: forall s k (n :: NetworkDiscriminant) shelley. From fe09015ddc7736633bdc27f080045e4418b6f55e Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 12:57:53 +0100 Subject: [PATCH 18/30] remove unnecessary polymorphism --- .../Api/Http/Server/Handlers/Certificates.hs | 59 ---- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 313 ++++++++++-------- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 11 +- lib/wallet/cardano-wallet.cabal | 1 - lib/wallet/src/Cardano/Wallet.hs | 191 +++++++---- 5 files changed, 305 insertions(+), 270 deletions(-) delete mode 100644 lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs deleted file mode 100644 index eccb255c095..00000000000 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Handlers/Certificates.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: © 2020 IOHK --- License: Apache-2.0 --- - -module Cardano.Wallet.Api.Http.Server.Handlers.Certificates - ( getApiAnyCertificates - ) - where - -import Cardano.Wallet.Api - ( ApiLayer ) -import Cardano.Wallet.Api.Http.Server.Error - ( liftHandler ) -import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR - ( ParsedTxCBOR (..) ) -import Cardano.Wallet.Api.Types.Certificate - ( ApiAnyCertificate, mkApiAnyCertificate ) -import Cardano.Wallet.DB - ( DBLayer ) -import Cardano.Wallet.Primitive.AddressDerivation - ( Depth (CredFromKeyK) ) -import Cardano.Wallet.Primitive.Types - ( WalletId ) -import Cardano.Wallet.Registry - ( WorkerCtx ) -import Data.Generics.Internal.VL - ( (^.) ) -import Data.Generics.Product - ( typed ) -import Data.Typeable - ( Typeable ) -import Prelude hiding - ( (.) ) -import Servant.Server - ( Handler ) - -import qualified Cardano.Wallet as W - --- | Promote certificates of a transaction to API type, --- using additional context from the 'WorkerCtx'. -getApiAnyCertificates - :: forall s k n - . (Typeable s, Typeable n) - => WorkerCtx (ApiLayer s k 'CredFromKeyK) - -> WalletId - -> ParsedTxCBOR - -> Handler [ApiAnyCertificate n] -getApiAnyCertificates wrk wid ParsedTxCBOR{certificates} = do - (acct, _, acctPath) <- liftHandler $ W.readRewardAccount @s @k @n db wid - pure $ mkApiAnyCertificate acct acctPath <$> certificates - where - db = wrk ^. typed @(DBLayer IO s k) 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 896dadc5b82..e5bb2825039 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 @@ -10,12 +10,12 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RecordWildCards #-} -- | -- Copyright: © 2018-2020 IOHK @@ -168,15 +168,16 @@ import Cardano.Wallet , ErrWalletAlreadyExists (..) , ErrWalletNotResponding (..) , ErrWithRootKey (..) - , ErrWithdrawalNotWorth (..) , ErrWitnessTx (..) , FeeEstimation (..) , HasNetworkLayer , TxSubmitLog + , WalletWorkerLog + , dbLayer , genesisData , manageRewardBalance - , dbLayer , networkLayer + , transactionLayer ) import Cardano.Wallet.Address.Book ( AddressBookIso ) @@ -195,12 +196,10 @@ import Cardano.Wallet.Api ) import Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..), apiError, handleWalletException, liftE, liftHandler ) -import Cardano.Wallet.Api.Http.Server.Handlers.Certificates - ( getApiAnyCertificates ) import Cardano.Wallet.Api.Http.Server.Handlers.MintBurn ( convertApiAssetMintBurn, getTxApiAssetMintBurn ) import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR - ( parseTxCBOR ) + ( ParsedTxCBOR (..), parseTxCBOR ) import Cardano.Wallet.Api.Http.Server.Tls ( TlsConfiguration (..), requireClientAuth ) import Cardano.Wallet.Api.Types @@ -579,7 +578,7 @@ import Data.Text.Class import Data.Time ( UTCTime ) import Data.Type.Equality - ( type (==), testEquality,type (:~:) (..) ) + ( (:~:) (..), type (==), testEquality ) import Data.Word ( Word32 ) import Fmt @@ -772,14 +771,12 @@ type MkApiWallet ctx s w postWallet :: forall ctx s k n. ( s ~ SeqState n k + , k ~ ShelleyKey , ctx ~ ApiLayer s k 'CredFromKeyK , Seq.SupportsDiscovery n k , WalletKey k , HasDBFactory s k ctx , HasWorkerRegistry s k ctx - , IsOurs s RewardAccount - , Typeable s - , (k == SharedKey) ~ 'False , AddressBookIso s , MaybeLight s ) @@ -789,15 +786,20 @@ postWallet -> WalletOrAccountPostData -> Handler ApiWallet postWallet ctx generateKey liftKey (WalletOrAccountPostData body) = case body of - Left body' -> - postShelleyWallet ctx generateKey body' + Left body' -> postShelleyWallet ctx generateKey body' Right body' -> - postAccountWallet ctx mkShelleyWallet liftKey - (W.manageRewardBalance @_ @s @k (Proxy @n)) body' + let action workerCtx = + W.manageRewardBalance + (workerCtx ^. typed @(Tracer IO WalletWorkerLog)) + (workerCtx ^. networkLayer) + (workerCtx ^. typed @(DBLayer IO (SeqState n ShelleyKey) k)) + + in postAccountWallet ctx mkShelleyWallet liftKey action body' postShelleyWallet :: forall ctx s k n. ( s ~ SeqState n k + , k ~ ShelleyKey , ctx ~ ApiLayer s k 'CredFromKeyK , WalletKey k , Seq.SupportsDiscovery n k @@ -805,8 +807,6 @@ postShelleyWallet , HasWorkerRegistry s k ctx , IsOurs s RewardAccount , MaybeLight s - , Typeable s - , (k == SharedKey) ~ 'False , AddressBookIso s ) => ctx @@ -817,7 +817,12 @@ postShelleyWallet ctx generateKey body = do let state = mkSeqStateFromRootXPrv (rootXPrv, pwdP) purposeCIP1852 g void $ liftHandler $ createWalletWorker @_ @s @k ctx wid (\wrk -> W.createWallet @(WorkerCtx ctx) @_ @s @k wrk wid wName state) - (\wrk _ -> W.manageRewardBalance @(WorkerCtx ctx) @s @k (Proxy @n) wrk wid) + (\workerCtx _ -> W.manageRewardBalance + (workerCtx ^. typed) + (workerCtx ^. typed) + (workerCtx ^. typed @(DBLayer IO (SeqState n ShelleyKey) k)) + wid + ) withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> liftHandler $ W.attachPrivateKeyFromPwd @_ @s @k wrk wid (rootXPrv, pwd) fst <$> getWallet ctx (mkShelleyWallet @_ @s @k) (ApiT wid) @@ -1613,8 +1618,9 @@ selectCoins :: forall s k n. ( IsOurs s Address , GenChange s - , Typeable n , Typeable s + , Typeable k + , Typeable n , BoundedAddressLength k ) => ApiLayer s k 'CredFromKeyK @@ -1630,7 +1636,8 @@ selectCoins ctx@ApiLayer {..} genChange (ApiT wid) body = do wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl + unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + netLayer txLayer db wid era apiWdrl let outs = addressAmountToTxOut <$> body ^. #payments let txCtx = defaultTransactionCtx { txWithdrawal = wdrl @@ -1653,16 +1660,17 @@ selectCoins ctx@ApiLayer {..} genChange (ApiT wid) body = do , selectionStrategy = SelectionStrategyOptimal } utx <- liftHandler $ - W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform + W.selectAssets @_ @_ @s @k @'CredFromKeyK + wrk era pp selectAssetsParams transform pure $ mkApiCoinSelection [] [] Nothing md utx selectCoinsForJoin :: forall ctx s n k. ( s ~ SeqState n k + , k ~ ShelleyKey , ctx ~ ApiLayer s k 'CredFromKeyK , DelegationAddress n k 'CredFromKeyK , Seq.SupportsDiscovery n k - , Typeable s , BoundedAddressLength k ) => ctx @@ -1708,29 +1716,33 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler - $ W.readRewardAccount @s @k @n (wrk ^. dbLayer) wid + $ W.readRewardAccount (wrk ^. dbLayer) wid let deposits = maybeToList deposit pure $ mkApiCoinSelection deposits [] (Just (action, path)) Nothing utx selectCoinsForQuit - :: forall n k. - ( DelegationAddress n k 'CredFromKeyK + :: forall s n k. + ( s ~ SeqState n k + , DelegationAddress n k 'CredFromKeyK , Seq.SupportsDiscovery n k - , BoundedAddressLength k + , Typeable s , Typeable k + , BoundedAddressLength k ) => ApiLayer (SeqState n k) k 'CredFromKeyK -> ApiT WalletId -> Handler (Api.ApiCoinSelection n) -selectCoinsForQuit ctx (ApiT wid) = do +selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) = withWorkerCtx ctx wid liftE liftE $ \wrk -> do - let db = wrk ^. typed @(DBLayer IO (SeqState n k) k) - let netLayer = wrk ^. networkLayer - wdrl <- liftHandler $ mkSelfWithdrawal @_ @k @n netLayer db wid + let db = wrk ^. typed @(DBLayer IO s k) + era <- liftIO $ NW.currentNodeEra netLayer + wdrl <- liftHandler $ ExceptT + $ W.unsafeShelleyMkSelfWithdrawal @s @k @_ @_ @n + netLayer txLayer era db wid action <- handleWalletException - $ W.validatedQuitStakePoolAction @(SeqState n k) @k db wid wdrl + $ W.validatedQuitStakePoolAction db wid wdrl let txCtx = defaultTransactionCtx { txDelegationAction = Just action @@ -1741,7 +1753,7 @@ selectCoinsForQuit ctx (ApiT wid) = do W.assignChangeAddresses (delegationAddress @n) sel s & uncurry (W.selectionToUnsignedTx (txWithdrawal txCtx)) (utxoAvailable, wallet, pendingTxs) <- - liftHandler $ W.readWalletUTxOIndex @_ @(SeqState n k) @k wrk wid + liftHandler $ W.readWalletUTxOIndex @_ @_ @k wrk wid let selectAssetsParams = W.SelectAssetsParams { outputs = [] , pendingTxs @@ -1752,13 +1764,12 @@ selectCoinsForQuit ctx (ApiT wid) = do , wallet , selectionStrategy = SelectionStrategyOptimal } - pp <- liftIO $ NW.currentProtocolParameters netLayer - utx <- liftHandler $ do - era <- liftIO $ NW.currentNodeEra netLayer - W.selectAssets @_ @_ @(SeqState n k) @k @'CredFromKeyK + pp <- liftIO $ NW.currentProtocolParameters netLayer + utx <- + liftHandler $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler - $ W.readRewardAccount @(SeqState n k) @k @n db wid + $ W.unsafeShelleyReadRewardAccount @s @k @n db wid let refund = W.stakeKeyDeposit pp pure $ mkApiCoinSelection [] [refund] (Just (action, path)) Nothing utx @@ -1979,10 +1990,12 @@ postTransactionOld , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) , Typeable n , Typeable s + , Typeable k , WalletKey k , AddressBookIso s , BoundedAddressLength k - , HasDelegation s) + , HasDelegation s + ) => ctx -> ArgGenChange s -> ApiT WalletId @@ -2002,7 +2015,8 @@ postTransactionOld ctx@ApiLayer{..} genChange (ApiT wid) body = do wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl + unsafeShelleyMkWithdrawal @s @k @n + netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl , txMetadata = md @@ -2041,7 +2055,7 @@ postTransactionOld ctx@ApiLayer{..} genChange (ApiT wid) body = do (timeInterpreter netLayer) wrk wid #pendingSince - $ MkApiTransactionParams + MkApiTransactionParams { txId = tx ^. #txId , txFee = tx ^. #fee , txInputs = NE.toList $ second Just <$> sel ^. #inputs @@ -2074,13 +2088,13 @@ deleteTransaction ctx (ApiT wid) (ApiTxId (ApiT (tid))) = do return NoContent listTransactions - :: forall ctx s k n. + :: forall s k n. ( Typeable s , Typeable n - , ctx ~ ApiLayer s k 'CredFromKeyK , HasDelegation s + , Typeable k ) - => ctx + => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> Maybe MinWithdrawal -> Maybe Iso8601Time @@ -2111,13 +2125,13 @@ listTransactions defaultSortOrder = Descending getTransaction - :: forall ctx s k n. + :: forall s k n. ( Typeable s , Typeable n - , ctx ~ ApiLayer s k 'CredFromKeyK + , Typeable k , HasDelegation s ) - => ctx + => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> ApiTxId -> TxMetadataSchema @@ -2134,7 +2148,7 @@ getTransaction ctx (ApiT wid) (ApiTxId (ApiT (tid))) metadataSchema = -- Populate an API transaction record with 'TransactionInfo' from the wallet -- layer. mkApiTransactionFromInfo - :: (Typeable s, Typeable n, HasDelegation s) + :: (Typeable s, Typeable n, HasDelegation s, Typeable k) => TimeInterpreter (ExceptT PastHorizonException IO) -> W.WalletLayer IO s k 'CredFromKeyK -> WalletId @@ -2175,7 +2189,11 @@ mkApiTransactionFromInfo ti wrk wid deposit info metadataSchema = do postTransactionFeeOld :: forall s k n - . (Typeable n, Typeable s, BoundedAddressLength k) + . ( Typeable n + , Typeable k + , Typeable s + , BoundedAddressLength k + ) => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> PostTransactionFeeOldData n @@ -2187,7 +2205,8 @@ postTransactionFeeOld ctx@ApiLayer{..} (ApiT wid) body = wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - mkWithdrawal @s @_ @n netLayer txLayer db wid era apiWdrl + unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl , txMetadata = body @@ -2224,6 +2243,7 @@ constructTransaction , IsOurs s Address , Typeable n , Typeable s + , Typeable k , WalletKey k , BoundedAddressLength k ) @@ -2314,11 +2334,13 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer netLayer = wrk ^. networkLayer + txLayer = wrk ^. transactionLayer pp <- liftIO $ NW.currentProtocolParameters netLayer era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of Just SelfWithdraw -> liftHandler - $ mkSelfWithdrawal @_ @k @n netLayer db wid + $ ExceptT $ W.unsafeShelleyMkSelfWithdrawal + @s @k @'CredFromKeyK @_ @n netLayer txLayer era db wid _ -> pure NoWithdrawal (deposit, refund, txCtx) <- case body ^. #delegations of Nothing -> pure (Nothing, Nothing, defaultTransactionCtx @@ -2459,7 +2481,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do tx <- liftHandler $ W.constructTransaction @_ @s @k @n wrk wid era txCtx' sel - pure $ ApiConstructTransaction + pure ApiConstructTransaction { transaction = case body ^. #encoding of Just HexEncoded -> ApiSerialisedTransaction (ApiT tx) HexEncoded _ -> ApiSerialisedTransaction (ApiT tx) Base64Encoded @@ -2827,19 +2849,19 @@ balanceTransaction ctx@ApiLayer{..} genChange (ApiT wid) body = do maybeToHandler e Nothing = liftHandler $ throwE e decodeTransaction - :: forall ctx s k n. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , IsOurs s Address + :: forall s k n. + ( IsOurs s Address , Typeable s , Typeable n - , HasNetworkLayer IO ctx + , Typeable k ) - => ctx + => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> ApiSerialisedTransaction -> Handler (ApiDecodedTransaction n) -decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do - era <- liftIO $ NW.currentNodeEra nl +decodeTransaction + ctx@ApiLayer{..} (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do + era <- liftIO $ NW.currentNodeEra netLayer let (decodedTx, toMint, toBurn, allCerts, interval, witsCount) = decodeTx tl era sealed Tx { txId @@ -2854,7 +2876,7 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer (acct, _, acctPath) <- - liftHandler $ W.readRewardAccount @s @k @n db wid + liftHandler $ W.unsafeShelleyReadRewardAccount @s @k @n db wid inputPaths <- liftHandler $ W.lookupTxIns @_ @s @k wrk wid $ fst <$> resolvedInputs @@ -2892,7 +2914,6 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do } where tl = ctx ^. W.transactionLayer @k @'CredFromKeyK - nl = ctx ^. W.networkLayer @IO toWrdl acct (rewardKey, (Coin c)) = if rewardKey == acct then @@ -2939,11 +2960,11 @@ toOut ((TxOut addr (TokenBundle (Coin c) tmap)), (Just path)) = submitTransaction :: forall ctx s k (n :: NetworkDiscriminant). ( ctx ~ ApiLayer s k 'CredFromKeyK + , s ~ SeqState n k , HasNetworkLayer IO ctx , IsOwned s k 'CredFromKeyK , Typeable s - , Typeable n - ) + , Typeable n, Typeable k) => ctx -> ApiT WalletId -> ApiSerialisedTransaction @@ -2956,7 +2977,7 @@ submitTransaction ctx apiw@(ApiT wid) apitx = do let sealedTx = getApiT . (view #serialisedTxSealed) $ apitx let (tx,_,_,_,_,_) = decodeTx tl era sealedTx - apiDecoded <- decodeTransaction @_ @s @k @n ctx apiw apitx + apiDecoded <- decodeTransaction @s @k @n ctx apiw apitx when (isForeign apiDecoded) $ liftHandler $ throwE ErrSubmitTransactionForeignWallet let ourOuts = getOurOuts apiDecoded @@ -2984,13 +3005,14 @@ submitTransaction ctx apiw@(ApiT wid) apitx = do [] -> Nothing _ -> error "impossible to be here due to check above" - when (witsRequiredForInputs > totalNumberOfWits) $ - liftHandler $ throwE $ - ErrSubmitTransactionPartiallySignedOrNoSignedTx witsRequiredForInputs totalNumberOfWits + when (witsRequiredForInputs > totalNumberOfWits) + $ liftHandler . throwE + $ ErrSubmitTransactionPartiallySignedOrNoSignedTx + witsRequiredForInputs totalNumberOfWits _ <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer - (acct, _, path) <- liftHandler $ W.readRewardAccount @s @k @n db wid + (acct, _, path) <- liftHandler $ W.unsafeShelleyReadRewardAccount @s @k @n db wid let wdrl = getOurWdrl acct path apiDecoded let txCtx = defaultTransactionCtx { -- TODO: [ADP-1193] @@ -3136,8 +3158,7 @@ joinStakePool , WalletKey k , AddressBookIso s , BoundedAddressLength k - , HasDelegation s - ) + , HasDelegation s, Typeable k) => ctx -> IO (Set PoolId) -- ^ Known pools @@ -3257,34 +3278,39 @@ delegationFee ctx (ApiT wid) = do } quitStakePool - :: forall ctx s n k. - ( ctx ~ ApiLayer s k 'CredFromKeyK - , s ~ SeqState n k + :: forall s n k. + ( s ~ SeqState n k , AddressIndexDerivationType k ~ 'Soft , DelegationAddress n k 'CredFromKeyK , GenChange s - , HasNetworkLayer IO ctx , IsOwned s k 'CredFromKeyK , SoftDerivation k , Typeable n , Typeable s + , Typeable k , WalletKey k , AddressBookIso s , BoundedAddressLength k , HasDelegation s ) - => ctx + => ApiLayer s k 'CredFromKeyK -> ApiT WalletId -> ApiWalletPassphrase -> Handler (ApiTransaction n) -quitStakePool ctx (ApiT walletId) body = do +quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (Just SelfWithdrawal) withWorkerCtx ctx walletId liftE liftE $ \wrk -> do - let db = wrk ^. dbLayer - netLayer = wrk ^. typed @(NetworkLayer IO Block) - txCtx <- handleWalletException - $ W.quitStakePool @s @k @n netLayer db ti walletId - + let db = wrk ^. typed @(DBLayer IO s k) + notShelleyWallet = + liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet + txCtx <- + case testEquality (typeRep @s) (typeRep @(SeqState n k)) of + Nothing -> notShelleyWallet + Just Refl -> case testEquality (typeRep @k) + (typeRep @ShelleyKey) of + Nothing -> notShelleyWallet + Just Refl -> handleWalletException $ + W.quitStakePool netLayer db ti walletId (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk walletId pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer) @@ -3303,7 +3329,8 @@ quitStakePool ctx (ApiT walletId) body = do } $ const Prelude.id sel' <- liftHandler - $ W.assignChangeAddressesAndUpdateDb wrk walletId genChange sel + $ W.assignChangeAddressesAndUpdateDb @_ @s @k + wrk walletId (delegationAddress @n @k @'CredFromKeyK) sel (tx, txMeta, txTime, sealedTx) <- do let pwd = coerce $ getApiT $ body ^. #passphrase liftHandler $ W.buildAndSignTransaction @_ @s @k @@ -3332,8 +3359,6 @@ quitStakePool ctx (ApiT walletId) body = do ti :: TimeInterpreter (ExceptT PastHorizonException IO) ti = timeInterpreter (ctx ^. networkLayer) - genChange = delegationAddress @n - -- More testable helper for `listStakeKeys`. -- -- TODO: Ideally test things like @@ -3398,21 +3423,20 @@ listStakeKeys' utxo lookupStakeRef fetchRewards ourKeysWithInfo = do } listStakeKeys - :: forall s n k - . (Typeable s, Typeable n) + :: forall s n + . (s ~ SeqState n ShelleyKey) => (Address -> Maybe RewardAccount) - -> ApiLayer s k 'CredFromKeyK + -> ApiLayer s ShelleyKey 'CredFromKeyK -> ApiT WalletId -> Handler (ApiStakeKeys n) listStakeKeys lookupStakeRef ctx@ApiLayer{..} (ApiT wid) = withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do - let db = wrk ^. dbLayer - (wal, (_, delegation) ,pending) <- W.readWallet @_ @s @k wrk wid + let db = wrk ^. typed @(DBLayer IO s ShelleyKey) + (wal, (_, delegation) ,pending) <- W.readWallet @_ @s @ShelleyKey wrk wid let utxo = availableUTxO @s pending wal - let takeFst (a,_,_) = a mourAccount <- fmap (fmap takeFst . eitherToMaybe) - <$> liftIO . runExceptT $ W.readRewardAccount @s @k @n db wid + <$> liftIO . runExceptT $ W.readRewardAccount @n db wid ourApiDelegation <- liftIO $ toApiWalletDelegation delegation (unsafeExtendSafeZone (timeInterpreter $ ctx ^. networkLayer)) let ourKeys = case mourAccount of @@ -3430,7 +3454,8 @@ listStakeKeys lookupStakeRef ctx@ApiLayer{..} (ApiT wid) = -------------------------------------------------------------------------------} createMigrationPlan - :: forall n s k. (IsOwned s k 'CredFromKeyK, Typeable n, Typeable s) + :: forall n s k + . (IsOwned s k 'CredFromKeyK, Typeable n, Typeable k, Typeable s) => ApiLayer s k 'CredFromKeyK -> Maybe ApiWithdrawalPostData -- ^ What type of reward withdrawal to attempt @@ -3443,11 +3468,10 @@ createMigrationPlan ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer era <- liftIO $ NW.currentNodeEra netLayer - rewardWithdrawal <- - maybe - (pure NoWithdrawal) - (mkWithdrawal @s @_ @n netLayer txLayer db wid era) - withdrawalType + rewardWithdrawal <- case withdrawalType of + Nothing -> pure NoWithdrawal + Just pd -> unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + netLayer txLayer db wid era pd (wallet, _, _) <- liftHandler $ withExceptT ErrCreateMigrationPlanNoSuchWallet $ W.readWallet wrk wid @@ -3457,8 +3481,8 @@ createMigrationPlan ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = $ mkApiWalletMigrationPlan (getState wallet) (view #addresses postData) - (rewardWithdrawal) - (plan) + rewardWithdrawal + plan mkApiWalletMigrationPlan :: forall n s. IsOurs s Address @@ -3527,6 +3551,7 @@ migrateWallet , IsOwned s k 'CredFromKeyK , Typeable n , Typeable s + , Typeable k , WalletKey k , HasDelegation s ) @@ -3541,11 +3566,10 @@ migrateWallet ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = do withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer era <- liftIO $ NW.currentNodeEra netLayer - rewardWithdrawal <- - maybe - (pure NoWithdrawal) - (mkWithdrawal @s @_ @n netLayer txLayer db wid era) - withdrawalType + rewardWithdrawal <- case withdrawalType of + Nothing -> pure NoWithdrawal + Just pd -> unsafeShelleyMkWithdrawal @s @k @n + netLayer txLayer db wid era pd plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal ttl <- liftIO $ W.transactionExpirySlot ti Nothing pp <- liftIO $ NW.currentProtocolParameters netLayer @@ -3766,9 +3790,11 @@ postAccountPublicKey -> ApiT DerivationIndex -> ApiPostAccountKeyDataWithPurpose -> Handler account -postAccountPublicKey ctx mkAccount (ApiT wid) (ApiT ix) (ApiPostAccountKeyDataWithPurpose (ApiT pwd) extd purposeM) = do +postAccountPublicKey ctx mkAccount (ApiT wid) (ApiT ix) + (ApiPostAccountKeyDataWithPurpose (ApiT pwd) extd purposeM) = do withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk -> do - k <- liftHandler $ W.getAccountPublicKeyAtIndex @_ @s @k wrk wid pwd ix (getApiT <$> purposeM) + k <- liftHandler $ W.getAccountPublicKeyAtIndex @_ @s @k + wrk wid pwd ix (getApiT <$> purposeM) pure $ mkAccount (publicKeyToBytes' extd $ getRawKey k) extd ixPurpose' where ixPurpose' = @@ -3885,47 +3911,43 @@ type RewardAccountBuilder k -> (XPrv, Passphrase "encryption") mkWithdrawal - :: forall s k (n :: NetworkDiscriminant) ktype tx - . (Typeable s, Typeable n) - => NetworkLayer IO Block - -> TransactionLayer k ktype tx - -> DBLayer IO s k + :: forall (n :: NetworkDiscriminant) ktype tx + . NetworkLayer IO Block + -> TransactionLayer ShelleyKey ktype tx + -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey -> WalletId -> AnyCardanoEra -> ApiWithdrawalPostData -> Handler Withdrawal mkWithdrawal netLayer txLayer db wallet era = \case SelfWithdrawal -> - liftHandler $ mkSelfWithdrawal @s @k @n netLayer db wallet - ExternalWithdrawal mnemonic -> - liftHandler $ mkExternalWithdrawal netLayer txLayer era mnemonic - -mkSelfWithdrawal - :: forall s k (n :: NetworkDiscriminant). (Typeable s, Typeable n) - => NetworkLayer IO Block + liftHandler . ExceptT + $ W.mkSelfWithdrawal netLayer txLayer era db wallet + ExternalWithdrawal (ApiMnemonicT mnemonic) -> + liftHandler . ExceptT + $ W.mkExternalWithdrawal netLayer txLayer era mnemonic + +-- | Unsafe version of `mkWithdrawal` that throws runtime error +-- when applied to a non-shelley or non-sequential wallet state. +unsafeShelleyMkWithdrawal + :: forall s k (n :: NetworkDiscriminant) ktype tx + . (Typeable n, Typeable s, Typeable k) + => NetworkLayer IO Block + -> TransactionLayer k ktype tx -> DBLayer IO s k -> WalletId - -> ExceptT ErrReadRewardAccount IO Withdrawal -mkSelfWithdrawal netLayer db wallet = do - (rewardAccount, _, derivationPath) <- W.readRewardAccount @s @k @n db wallet - liftIO $ WithdrawalSelf rewardAccount derivationPath <$> - getCachedRewardAccountBalance netLayer rewardAccount - -mkExternalWithdrawal - :: forall k ktype tx - . NetworkLayer IO Block - -> TransactionLayer k ktype tx -> AnyCardanoEra - -> ApiMnemonicT '[15,18,21,24] - -> ExceptT ErrWithdrawalNotWorth IO Withdrawal -mkExternalWithdrawal netLayer txLayer era (ApiMnemonicT mnemonic) = do - let (_, rewardAccount, derivationPath) = - W.someRewardAccount @ShelleyKey mnemonic - withdrawalCoins <- liftIO $ do - balance <- getCachedRewardAccountBalance netLayer rewardAccount - W.readNextWithdrawal netLayer txLayer era balance - when (withdrawalCoins == Coin 0) $ throwE ErrWithdrawalNotWorth - pure $ WithdrawalExternal rewardAccount derivationPath withdrawalCoins + -> ApiWithdrawalPostData + -> Handler Withdrawal +unsafeShelleyMkWithdrawal netLayer txLayer db wallet era postData = + case testEquality (typeRep @s) (typeRep @(SeqState n k)) of + Nothing -> notShelleyWallet + Just Refl -> case testEquality (typeRep @k) (typeRep @ShelleyKey) of + Nothing -> notShelleyWallet + Just Refl -> mkWithdrawal netLayer txLayer db wallet era postData + where + notShelleyWallet = + liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet mkRewardAccountBuilder :: forall s k (n :: NetworkDiscriminant) @@ -4079,7 +4101,8 @@ data MkApiTransactionParams = MkApiTransactionParams deriving (Eq, Generic, Show) mkApiTransaction - :: forall n s k . (Typeable s, Typeable n, HasDelegation s) + :: forall n s k + . (Typeable s, Typeable n, Typeable k, HasDelegation s) => TimeInterpreter (ExceptT PastHorizonException IO) -> W.WalletLayer IO s k 'CredFromKeyK -> WalletId @@ -4087,6 +4110,7 @@ mkApiTransaction -> MkApiTransactionParams -> Handler (ApiTransaction n) mkApiTransaction timeInterpreter wrk wid timeRefLens tx = do + let db = wrk ^. typed @(DBLayer IO s k) timeRef <- liftIO $ (#time .~ tx ^. #txTime) <$> makeApiBlockReference (neverFails "makeApiBlockReference shouldn't fail getting the time of \ @@ -4095,9 +4119,10 @@ mkApiTransaction timeInterpreter wrk wid timeRefLens tx = do (natural (tx ^. #txMeta . #blockHeight)) expRef <- liftIO $ traverse makeApiSlotReference' (tx ^. #txMeta . #expiry) parsedValues <- traverse parseTxCBOR $ tx ^. #txCBOR - parsedCertificates <- if hasDelegation (Proxy @s) - then traverse (getApiAnyCertificates wrk wid) parsedValues - else pure Nothing + parsedCertificates <- + if hasDelegation (Proxy @s) + then traverse (getApiAnyCertificates db) parsedValues + else pure Nothing parsedMintBurn <- forM parsedValues $ getTxApiAssetMintBurn @_ @s @k @n wrk wid @@ -4144,6 +4169,14 @@ mkApiTransaction timeInterpreter wrk wid timeRefLens tx = do -- now. makeApiSlotReference' = makeApiSlotReference $ unsafeExtendSafeZone timeInterpreter + + -- | Promote certificates of a transaction to API type, + -- using additional context from the 'WorkerCtx'. + getApiAnyCertificates db ParsedTxCBOR{certificates} = do + (rewardAccount, _, derivPath) <- liftHandler + $ W.unsafeShelleyReadRewardAccount @s @k @n db wid + pure $ mkApiAnyCertificate rewardAccount derivPath <$> certificates + depositIfAny :: Natural depositIfAny | tx ^. (#txMeta . #direction) == W.Outgoing = diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 5452e736346..80952258569 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -137,6 +137,10 @@ import Control.Tracer ( Tracer, traceWith ) import Data.Function ( (&) ) +import Data.Generics.Internal.VL + ( view ) +import Data.Generics.Product + ( typed ) import Data.Maybe ( fromJust ) import Data.Proxy @@ -288,8 +292,11 @@ serveWallet lift $ apiLayer (newTransactionLayer netId) netLayer Server.idleWorker withShelleyApi netLayer = - lift $ apiLayer (newTransactionLayer netId) netLayer - (Server.manageRewardBalance proxyNetwork) + lift $ apiLayer (newTransactionLayer netId) netLayer $ + Server.manageRewardBalance + <$> view typed + <*> view typed + <*> view typed withMultisigApi netLayer = lift $ apiLayer (newTransactionLayer netId) netLayer Server.idleWorker diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index d77cf7061f1..bcd2a56dead 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -486,7 +486,6 @@ library cardano-wallet-api-http Cardano.Wallet.Api.Http.Logging Cardano.Wallet.Api.Http.Server Cardano.Wallet.Api.Http.Server.Error - Cardano.Wallet.Api.Http.Server.Handlers.Certificates Cardano.Wallet.Api.Http.Server.Handlers.MintBurn Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR Cardano.Wallet.Api.Http.Server.Tls diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 7f7ebcd7374..9c7dcf4836c 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -79,8 +79,11 @@ module Cardano.Wallet , manageRewardBalance , rollbackBlocks , checkWalletIntegrity - , readNextWithdrawal + , mkExternalWithdrawal + , mkSelfWithdrawal + , unsafeShelleyMkSelfWithdrawal , readRewardAccount + , unsafeShelleyReadRewardAccount , someRewardAccount , readPolicyPublicKey , writePolicyPublicKey @@ -219,13 +222,15 @@ import Cardano.Address.Script import Cardano.Address.Style.Shared ( deriveDelegationPublicKey ) import Cardano.Api - ( serialiseToCBOR ) + ( AnyCardanoEra, serialiseToCBOR ) import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.Crypto.Wallet ( toXPub ) +import Cardano.Mnemonic + ( SomeMnemonic ) import Cardano.Pool.Types ( PoolId ) import Cardano.Slotting.Slot @@ -1197,30 +1202,75 @@ deleteWallet ctx wid = db & \DBLayer{..} -> do -- | Fetch the cached reward balance of a given wallet from the database. fetchRewardBalance :: forall s k. DBLayer IO s k -> WalletId -> IO Coin -fetchRewardBalance db wid = db & \DBLayer{..} -> - atomically $ readDelegationRewardBalance wid +fetchRewardBalance DBLayer{..} = atomically . readDelegationRewardBalance --- | Read the current withdrawal capacity of a wallet. Note that, this simply --- returns 0 if: --- --- a) There's no reward account for this type of wallet. --- b) The current reward value is too small to be considered (adding it would --- cost more than its value). -readNextWithdrawal +mkExternalWithdrawal :: forall k ktype tx . NetworkLayer IO Block -> TransactionLayer k ktype tx - -> Cardano.AnyCardanoEra - -> Coin - -> IO Coin -readNextWithdrawal netLayer txLayer era (Coin withdrawal) = do + -> AnyCardanoEra + -> SomeMnemonic + -> IO (Either ErrWithdrawalNotWorth Withdrawal) +mkExternalWithdrawal netLayer txLayer era mnemonic = do + let (_, rewardAccount, derivationPath) = + someRewardAccount @ShelleyKey mnemonic + balance <- getCachedRewardAccountBalance netLayer rewardAccount pp <- currentProtocolParameters netLayer + pure $ checkRewardIsWorthTxCost txLayer pp era balance $> + WithdrawalExternal rewardAccount derivationPath balance + +mkSelfWithdrawal + :: forall ktype tx (n :: NetworkDiscriminant) + . NetworkLayer IO Block + -> TransactionLayer ShelleyKey ktype tx + -> AnyCardanoEra + -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey + -> WalletId + -> IO (Either ErrWithdrawalNotWorth Withdrawal) +mkSelfWithdrawal netLayer txLayer era db wallet = do + (rewardAccount, _, derivationPath) <- + runExceptT (readRewardAccount db wallet) + >>= either (throw . ExceptionReadRewardAccount) pure + balance <- getCachedRewardAccountBalance netLayer rewardAccount + pp <- currentProtocolParameters netLayer + pure $ checkRewardIsWorthTxCost txLayer pp era balance $> + WithdrawalSelf rewardAccount derivationPath balance + +-- | Unsafe version of the `mkSelfWithdrawal` function that throws an exception +-- when applied to a non-shelley or a non-sequential wallet. +unsafeShelleyMkSelfWithdrawal + :: forall s k ktype tx (n :: NetworkDiscriminant) + . (Typeable s, Typeable k, Typeable n) + => NetworkLayer IO Block + -> TransactionLayer k ktype tx + -> AnyCardanoEra + -> DBLayer IO s k + -> WalletId + -> IO (Either ErrWithdrawalNotWorth Withdrawal) +unsafeShelleyMkSelfWithdrawal netLayer txLayer era db wallet = + case testEquality (typeRep @s) (typeRep @(SeqState n k)) of + Nothing -> notShelleyWallet + Just Refl -> case testEquality (typeRep @k) (typeRep @ShelleyKey) of + Nothing -> notShelleyWallet + Just Refl -> mkSelfWithdrawal netLayer txLayer era db wallet + where + notShelleyWallet = throw + $ ExceptionReadRewardAccount ErrReadRewardAccountNotAShelleyWallet + +checkRewardIsWorthTxCost + :: forall k ktype tx + . TransactionLayer k ktype tx + -> ProtocolParameters + -> AnyCardanoEra + -> Coin + -> Either ErrWithdrawalNotWorth () +checkRewardIsWorthTxCost txLayer pp era balance = do let minimumCost txCtx = calcMinimumCost txLayer era pp txCtx emptySkeleton - costWith = minimumCost $ mkTxCtx $ Coin withdrawal + costWith = minimumCost $ mkTxCtx balance costWithout = minimumCost $ mkTxCtx $ Coin 0 costOfWithdrawal = Coin.toInteger costWith - Coin.toInteger costWithout - pure . Coin $ - if toInteger withdrawal < 2 * costOfWithdrawal then 0 else withdrawal + when (Coin.toInteger balance < 2 * costOfWithdrawal) + $ Left ErrWithdrawalNotWorth where mkTxCtx wdrl = defaultTransactionCtx { txWithdrawal = WithdrawalSelf dummyAcct dummyPath wdrl } @@ -1229,28 +1279,42 @@ readNextWithdrawal netLayer txLayer era (Coin withdrawal) = do dummyPath = DerivationIndex 0 :| [] readRewardAccount - :: forall s k (n :: NetworkDiscriminant) shelley. - ( shelley ~ SeqState n ShelleyKey - , Typeable n - , Typeable s - ) + :: forall (n :: NetworkDiscriminant) + . DBLayer IO (SeqState n ShelleyKey) ShelleyKey + -> WalletId + -> ExceptT ErrReadRewardAccount IO + (RewardAccount, XPub, NonEmpty DerivationIndex) +readRewardAccount db wid = do + walletState <- getState <$> + withExceptT ErrReadRewardAccountNoSuchWallet + (readWalletCheckpoint db wid) + let xpub = Seq.rewardAccountKey walletState + let path = stakeDerivationPath $ Seq.derivationPrefix walletState + pure (toRewardAccount xpub, getRawKey xpub, path) + where + readWalletCheckpoint :: + DBLayer IO s k -> WalletId -> ExceptT ErrNoSuchWallet IO (Wallet s) + readWalletCheckpoint DBLayer{..} wallet = + liftIO (atomically (readCheckpoint wallet)) >>= + maybe (throwE (ErrNoSuchWallet wallet)) pure + +-- | Unsafe version of the `readRewardAccount` function +-- that throws error when applied to a non-sequential +-- or a non-shelley wallet state. +unsafeShelleyReadRewardAccount + :: forall s k (n :: NetworkDiscriminant) + . (Typeable s, Typeable n, Typeable k) => DBLayer IO s k -> WalletId - -> ExceptT ErrReadRewardAccount IO (RewardAccount, XPub, NonEmpty DerivationIndex) -readRewardAccount db wid = db & \DBLayer{..} -> do - cp <- withExceptT ErrReadRewardAccountNoSuchWallet - $ mapExceptT atomically - $ withNoSuchWallet wid - $ readCheckpoint wid - case testEquality (typeRep @s) (typeRep @shelley) of - Nothing -> - throwE ErrReadRewardAccountNotAShelleyWallet - Just Refl -> do - let s = getState cp - let xpub = Seq.rewardAccountKey s - let acct = toRewardAccount xpub - let path = stakeDerivationPath $ Seq.derivationPrefix s - pure (acct, getRawKey xpub, path) + -> ExceptT ErrReadRewardAccount IO + (RewardAccount, XPub, NonEmpty DerivationIndex) +unsafeShelleyReadRewardAccount db wid = + case testEquality (typeRep @s) (typeRep @(SeqState n k)) of + Nothing -> throwE ErrReadRewardAccountNotAShelleyWallet + Just Refl -> + case testEquality (typeRep @k) (typeRep @ShelleyKey) of + Nothing -> throwE ErrReadRewardAccountNotAShelleyWallet + Just Refl -> readRewardAccount db wid readPolicyPublicKey :: forall ctx s k (n :: NetworkDiscriminant) shelley. @@ -1273,32 +1337,25 @@ readPolicyPublicKey ctx wid = db & \DBLayer{..} -> do Just Refl -> do let s = getState cp case Seq.policyXPub s of - Nothing -> - throwE ErrReadPolicyPublicKeyAbsent - Just xpub -> - pure (getRawKey xpub, policyDerivationPath) + Nothing -> throwE ErrReadPolicyPublicKeyAbsent + Just xpub -> pure (getRawKey xpub, policyDerivationPath) where db = ctx ^. dbLayer @IO @s @k manageRewardBalance - :: forall ctx s k (n :: NetworkDiscriminant). - ( HasLogger IO WalletWorkerLog ctx - , HasNetworkLayer IO ctx - , HasDBLayer IO s k ctx - , Typeable s - , Typeable n - ) - => Proxy n - -> ctx + :: forall (n :: NetworkDiscriminant) + . Tracer IO WalletWorkerLog + -> NetworkLayer IO Block + -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey -> WalletId -> IO () -manageRewardBalance _ ctx wid = db & \DBLayer{..} -> do - watchNodeTip $ \bh -> do +manageRewardBalance tr' netLayer db@DBLayer{..} wid = do + watchNodeTip netLayer $ \bh -> do traceWith tr $ MsgRewardBalanceQuery bh query <- runExceptT $ do - (acct, _, _) <- withExceptT ErrFetchRewardsReadRewardAccount $ - readRewardAccount @s @k @n db wid - liftIO $ getCachedRewardAccountBalance (ctx ^. networkLayer) acct + (acct, _, _) <- withExceptT ErrFetchRewardsReadRewardAccount + $ readRewardAccount db wid + liftIO $ getCachedRewardAccountBalance netLayer acct traceWith tr $ MsgRewardBalanceResult query case query of Right amt -> do @@ -1317,9 +1374,7 @@ manageRewardBalance _ ctx wid = db & \DBLayer{..} -> do traceWith tr MsgRewardBalanceExited where - db = ctx ^. dbLayer @IO @s @k - NetworkLayer{watchNodeTip} = ctx ^. networkLayer - tr = contramap MsgWallet $ ctx ^. logger @_ @WalletWorkerLog + tr = contramap MsgWallet tr' {------------------------------------------------------------------------------- Address @@ -2456,7 +2511,6 @@ buildAndSignTransaction ctx wid era mkRwdAcct pwd txCtx sel = db & \DBLayer{..} nl = ctx ^. networkLayer ti = timeInterpreter nl - -- | Construct an unsigned transaction from a given selection. constructTransaction :: forall ctx s k (n :: NetworkDiscriminant). @@ -2465,6 +2519,7 @@ constructTransaction , HasNetworkLayer IO ctx , Typeable s , Typeable n + , Typeable k ) => ctx -> WalletId @@ -2474,7 +2529,7 @@ constructTransaction -> ExceptT ErrConstructTx IO SealedTx constructTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do (_, xpub, _) <- withExceptT ErrConstructTxReadRewardAccount $ - readRewardAccount @s @k @n db wid + unsafeShelleyReadRewardAccount @s @k @n db wid mapExceptT atomically $ do pp <- liftIO $ currentProtocolParameters nl withExceptT ErrConstructTxBody $ ExceptT $ pure $ @@ -3061,11 +3116,12 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid = -- | Helper function to factor necessary logic for quitting a stake pool. validatedQuitStakePoolAction - :: forall s k. DBLayer IO s k + :: forall s k + . DBLayer IO s k -> WalletId -> Withdrawal -> IO DelegationAction -validatedQuitStakePoolAction db walletId withdrawal = db & \DBLayer{..} -> do +validatedQuitStakePoolAction db@DBLayer{..} walletId withdrawal = do (_, delegation) <- atomically (readWalletMeta walletId) >>= maybe (throw (ExceptionStakePoolDelegation @@ -3078,16 +3134,15 @@ validatedQuitStakePoolAction db walletId withdrawal = db & \DBLayer{..} -> do (guardQuit delegation withdrawal rewards) quitStakePool - :: forall s k (n :: NetworkDiscriminant) - . (Typeable s, Typeable n) - => NetworkLayer IO Block - -> DBLayer IO s k + :: forall (n :: NetworkDiscriminant) + . NetworkLayer IO Block + -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey -> TimeInterpreter (ExceptT PastHorizonException IO) -> WalletId -> IO TransactionCtx quitStakePool netLayer db timeInterpreter walletId = do (rewardAccount, _, derivationPath) <- - runExceptT (readRewardAccount @s @k @n db walletId) + runExceptT (readRewardAccount db walletId) >>= either (throw . ExceptionReadRewardAccount) pure withdrawal <- WithdrawalSelf rewardAccount derivationPath <$> getCachedRewardAccountBalance netLayer rewardAccount From 2916b9c6d5b5280ba584ec5a6f0945c032d78e2a Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 14:26:31 +0100 Subject: [PATCH 19/30] WalletException gets converted to ServerError in hoistServer --- .../Cardano/Wallet/Api/Http/Server/Error.hs | 14 ++-------- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 9 +++---- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 27 ++++++++++++++++--- 3 files changed, 30 insertions(+), 20 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs index d89c8bda615..38b5fe3e957 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs @@ -17,7 +17,6 @@ module Cardano.Wallet.Api.Http.Server.Error ( IsServerError (..) , liftHandler , liftE - , handleWalletException , apiError , err425 , showT @@ -103,16 +102,12 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Shared ( ErrAddCosigner (..), ErrScriptTemplate (..) ) import Cardano.Wallet.Primitive.Slotting ( PastHorizonException ) -import Cardano.Wallet.Primitive.Types.TokenBundle +import Cardano.Wallet.Primitive.Types.TokenMap ( Flat (..) ) import Cardano.Wallet.Transaction ( ErrAssignRedeemers (..), ErrSignTx (..) ) -import Control.Exception - ( try ) import Control.Monad.Except ( ExceptT, withExceptT ) -import Control.Monad.IO.Class - ( liftIO ) import Control.Monad.Trans.Except ( throwE ) import Data.Generics.Internal.VL @@ -140,7 +135,7 @@ import Network.Wai import Safe ( fromJustNote ) import Servant - ( Accept (contentType), JSON, Proxy (Proxy), throwError ) + ( Accept (contentType), JSON, Proxy (Proxy) ) import Servant.Server ( Handler (Handler) , ServerError (..) @@ -177,11 +172,6 @@ class IsServerError e where liftHandler :: IsServerError e => ExceptT e IO a -> Handler a liftHandler action = Handler (withExceptT toServerError action) -handleWalletException :: IO a -> Handler a -handleWalletException action = - liftIO (try @WalletException action) >>= - either (throwError . toServerError) pure - liftE :: IsServerError e => e -> Handler a liftE = liftHandler . throwE 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 e5bb2825039..fc464e0a93e 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 @@ -195,7 +195,7 @@ import Cardano.Wallet.Api , workerRegistry ) import Cardano.Wallet.Api.Http.Server.Error - ( IsServerError (..), apiError, handleWalletException, liftE, liftHandler ) + ( IsServerError (..), apiError, liftE, liftHandler ) import Cardano.Wallet.Api.Http.Server.Handlers.MintBurn ( convertApiAssetMintBurn, getTxApiAssetMintBurn ) import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR @@ -1741,8 +1741,7 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) = wdrl <- liftHandler $ ExceptT $ W.unsafeShelleyMkSelfWithdrawal @s @k @_ @_ @n netLayer txLayer era db wid - action <- handleWalletException - $ W.validatedQuitStakePoolAction db wid wdrl + action <- liftIO $ W.validatedQuitStakePoolAction db wid wdrl let txCtx = defaultTransactionCtx { txDelegationAction = Just action @@ -2362,7 +2361,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do @_ @s @k wrk curEpoch pools pid poolStatus wid pure (del, act, Nothing) [(Leaving _)] -> do - del <- handleWalletException $ + del <- liftIO $ W.validatedQuitStakePoolAction @s @k db wid wdrl pure (del, Nothing, Just $ W.stakeKeyDeposit pp) _ -> @@ -3309,7 +3308,7 @@ quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do Just Refl -> case testEquality (typeRep @k) (typeRep @ShelleyKey) of Nothing -> notShelleyWallet - Just Refl -> handleWalletException $ + Just Refl -> liftIO $ W.quitStakePool netLayer db ti walletId (utxoAvailable, wallet, pendingTxs) <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk walletId diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 80952258569..f2a119c5a54 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -29,6 +29,8 @@ import Prelude import Cardano.Api ( NetworkId ) +import Cardano.Wallet + ( WalletException ) import Cardano.Wallet.Api ( ApiLayer, ApiV2 ) import Cardano.Wallet.Api.Http.Logging @@ -36,7 +38,12 @@ import Cardano.Wallet.Api.Http.Logging import Cardano.Wallet.Api.Http.Server ( server ) import Cardano.Wallet.Api.Http.Shelley.Server - ( HostPreference, Listen (..), ListenError (..), TlsConfiguration ) + ( HostPreference + , Listen (..) + , ListenError (..) + , TlsConfiguration + , toServerError + ) import Cardano.Wallet.DB.Sqlite.Migration ( DefaultFieldValues (..) ) import Cardano.Wallet.DB.Store.Checkpoints @@ -129,10 +136,14 @@ import Cardano.Wallet.Tracers as Tracers ) import Cardano.Wallet.Transaction ( TransactionLayer ) +import Control.Exception + ( handle, throwIO ) import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Cont ( ContT (ContT), evalContT ) +import Control.Monad.Trans.Except + ( ExceptT (ExceptT) ) import Control.Tracer ( Tracer, traceWith ) import Data.Function @@ -168,6 +179,7 @@ import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Cardano.Wallet.DB.Layer as Sqlite import qualified Network.Wai.Handler.Warp as Warp +import qualified Servant.Server as Servant -- | The @cardano-wallet@ main function. It takes the configuration -- which was passed from the CLI and environment and starts all components of @@ -326,8 +338,10 @@ serveWallet serverUrl <- getServerUrl tlsConfig socket let serverSettings = Warp.defaultSettings & setBeforeMainLoop (beforeMainLoop serverUrl) - let application = Server.serve (Proxy @(ApiV2 n)) $ - server byron icarus shelley multisig spl ntp blockchainSource + api = Proxy @(ApiV2 n) + let application = Server.serve api + $ Servant.hoistServer api handleWalletExceptions + $ server byron icarus shelley multisig spl ntp blockchainSource Server.start serverSettings apiServerTracer tlsConfig socket application apiLayer @@ -395,6 +409,13 @@ serveWallet tokenMetaClient coworker +handleWalletExceptions :: forall x. Servant.Handler x -> Servant.Handler x +handleWalletExceptions = + Servant.Handler . ExceptT . walletExceptionToServerErr . Servant.runHandler + where + walletExceptionToServerErr = handle $ \(e :: WalletException) -> + throwIO (toServerError e) + withNtpClient :: Tracer IO NtpTrace -> ContT r IO NtpClient withNtpClient tr = do iom <- ContT withIOManager From 7a083a4937f5115bb3cd84e43ec95b3801697bf1 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 15:15:10 +0100 Subject: [PATCH 20/30] refactor: rename `c` to `coin` --- lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs index 38b5fe3e957..04f13b2a71d 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs @@ -511,10 +511,10 @@ instance IsServerError ErrBalanceTx where instance IsServerError ErrBalanceTxInternalError where toServerError = \case - ErrUnderestimatedFee co _st -> + ErrUnderestimatedFee coin _st -> apiError err500 BalanceTxUnderestimatedFee $ T.unwords [ "I have somehow underestimated the fee of the transaction by" - , pretty co + , pretty coin , "and cannot finish balancing." ] ErrFailedBalancing v -> From 2620043cbaa4a37e319ac80f6dc99cbcf9dfe9fc Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 15:52:08 +0100 Subject: [PATCH 21/30] WalletException gets converted to ServerError in hoistServer --- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index f2a119c5a54..f30e5f86e82 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -136,14 +136,12 @@ import Cardano.Wallet.Tracers as Tracers ) import Cardano.Wallet.Transaction ( TransactionLayer ) -import Control.Exception - ( handle, throwIO ) import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Cont ( ContT (ContT), evalContT ) import Control.Monad.Trans.Except - ( ExceptT (ExceptT) ) + ( ExceptT (ExceptT), mapExceptT ) import Control.Tracer ( Tracer, traceWith ) import Data.Function @@ -178,7 +176,11 @@ import Type.Reflection import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Cardano.Wallet.DB.Layer as Sqlite +import Control.Exception.Extra + ( handle ) import qualified Network.Wai.Handler.Warp as Warp +import Servant.Server + ( ServerError ) import qualified Servant.Server as Servant -- | The @cardano-wallet@ main function. It takes the configuration @@ -411,10 +413,11 @@ serveWallet handleWalletExceptions :: forall x. Servant.Handler x -> Servant.Handler x handleWalletExceptions = - Servant.Handler . ExceptT . walletExceptionToServerErr . Servant.runHandler + Servant.Handler . mapExceptT handleServerErr . ExceptT . Servant.runHandler where - walletExceptionToServerErr = handle $ \(e :: WalletException) -> - throwIO (toServerError e) + handleServerErr :: IO (Either ServerError x) -> IO (Either ServerError x) + handleServerErr = handle $ \(e :: WalletException) -> + pure (Left (toServerError e)) withNtpClient :: Tracer IO NtpTrace -> ContT r IO NtpClient withNtpClient tr = do From 5848c76676cf5f8822df79783814950e613a0a1e Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 19:44:10 +0100 Subject: [PATCH 22/30] Replace throw with throwIO --- lib/wallet/src/Cardano/Wallet.hs | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 9c7dcf4836c..3213441ceb2 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -483,8 +483,6 @@ import Control.Arrow ( first, left ) import Control.DeepSeq ( NFData ) -import Control.Exception - ( throw ) import Control.Monad ( forM, forM_, replicateM, unless, when ) import Control.Monad.Class.MonadTime @@ -819,10 +817,10 @@ checkWalletIntegrity :: DBLayer IO s k -> WalletId -> GenesisParameters -> IO () checkWalletIntegrity db walletId gp = db & \DBLayer{..} -> do gp' <- atomically (readGenesisParameters walletId) >>= do let noSuchWallet = ErrNoSuchWallet walletId - maybe (throw $ ErrCheckWalletIntegrityNoSuchWallet noSuchWallet) pure + maybe (throwIO $ ErrCheckWalletIntegrityNoSuchWallet noSuchWallet) pure when ( (gp ^. #getGenesisBlockHash /= gp' ^. #getGenesisBlockHash) || (gp ^. #getGenesisBlockDate /= gp' ^. #getGenesisBlockDate) ) - (throw $ ErrCheckIntegrityDifferentGenesis + (throwIO $ ErrCheckIntegrityDifferentGenesis (getGenesisBlockHash gp) (getGenesisBlockHash gp')) -- | Retrieve the wallet state for the wallet with the given ID. @@ -1230,7 +1228,7 @@ mkSelfWithdrawal mkSelfWithdrawal netLayer txLayer era db wallet = do (rewardAccount, _, derivationPath) <- runExceptT (readRewardAccount db wallet) - >>= either (throw . ExceptionReadRewardAccount) pure + >>= either (throwIO . ExceptionReadRewardAccount) pure balance <- getCachedRewardAccountBalance netLayer rewardAccount pp <- currentProtocolParameters netLayer pure $ checkRewardIsWorthTxCost txLayer pp era balance $> @@ -1254,7 +1252,7 @@ unsafeShelleyMkSelfWithdrawal netLayer txLayer era db wallet = Nothing -> notShelleyWallet Just Refl -> mkSelfWithdrawal netLayer txLayer era db wallet where - notShelleyWallet = throw + notShelleyWallet = throwIO $ ExceptionReadRewardAccount ErrReadRewardAccountNotAShelleyWallet checkRewardIsWorthTxCost @@ -3124,14 +3122,14 @@ validatedQuitStakePoolAction validatedQuitStakePoolAction db@DBLayer{..} walletId withdrawal = do (_, delegation) <- atomically (readWalletMeta walletId) >>= maybe - (throw (ExceptionStakePoolDelegation + (throwIO (ExceptionStakePoolDelegation (ErrStakePoolDelegationNoSuchWallet (ErrNoSuchWallet walletId)))) pure rewards <- liftIO $ fetchRewardBalance @s @k db walletId - Quit <$ - either (throw . ExceptionStakePoolDelegation . ErrStakePoolQuit) pure - (guardQuit delegation withdrawal rewards) + either (throwIO . ExceptionStakePoolDelegation . ErrStakePoolQuit) pure + (guardQuit delegation withdrawal rewards) + pure Quit quitStakePool :: forall (n :: NetworkDiscriminant) @@ -3143,7 +3141,7 @@ quitStakePool quitStakePool netLayer db timeInterpreter walletId = do (rewardAccount, _, derivationPath) <- runExceptT (readRewardAccount db walletId) - >>= either (throw . ExceptionReadRewardAccount) pure + >>= either (throwIO . ExceptionReadRewardAccount) pure withdrawal <- WithdrawalSelf rewardAccount derivationPath <$> getCachedRewardAccountBalance netLayer rewardAccount action <- validatedQuitStakePoolAction db walletId withdrawal From 239d8fc789e0dab97dbd525f83eecf0ffbc1d4ab Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 7 Nov 2022 19:47:41 +0100 Subject: [PATCH 23/30] chore: reorder imports --- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index f30e5f86e82..68da23ea390 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -136,6 +136,8 @@ import Cardano.Wallet.Tracers as Tracers ) import Cardano.Wallet.Transaction ( TransactionLayer ) +import Control.Exception.Extra + ( handle ) import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Cont @@ -166,6 +168,8 @@ import Network.Wai.Handler.Warp ( setBeforeMainLoop ) import Ouroboros.Network.Client.Wallet ( PipeliningStrategy ) +import Servant.Server + ( ServerError ) import System.Exit ( ExitCode (..) ) import System.IOManager @@ -176,11 +180,7 @@ import Type.Reflection import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Cardano.Wallet.DB.Layer as Sqlite -import Control.Exception.Extra - ( handle ) import qualified Network.Wai.Handler.Warp as Warp -import Servant.Server - ( ServerError ) import qualified Servant.Server as Servant -- | The @cardano-wallet@ main function. It takes the configuration From fe4adf5a39ac239e4796d5bf4cf930dac182b3c9 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 8 Nov 2022 08:37:26 +0100 Subject: [PATCH 24/30] refactor: simplify handleWalletExceptions --- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 68da23ea390..6f617d85aec 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -143,7 +143,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Cont ( ContT (ContT), evalContT ) import Control.Monad.Trans.Except - ( ExceptT (ExceptT), mapExceptT ) + ( ExceptT (ExceptT) ) import Control.Tracer ( Tracer, traceWith ) import Data.Function @@ -413,11 +413,10 @@ serveWallet handleWalletExceptions :: forall x. Servant.Handler x -> Servant.Handler x handleWalletExceptions = - Servant.Handler . mapExceptT handleServerErr . ExceptT . Servant.runHandler - where - handleServerErr :: IO (Either ServerError x) -> IO (Either ServerError x) - handleServerErr = handle $ \(e :: WalletException) -> - pure (Left (toServerError e)) + Servant.Handler + . ExceptT + . handle (pure . Left . toServerError @WalletException) + . Servant.runHandler withNtpClient :: Tracer IO NtpTrace -> ContT r IO NtpClient withNtpClient tr = do From bec7ecc967f489014cfd3d79ed5cda864c9cd041 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Tue, 8 Nov 2022 12:40:22 +0100 Subject: [PATCH 25/30] Split mkRewardAccoundBuilder into smaller builders --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 79 +++++++++++-------- lib/wallet/api/http/Cardano/Wallet/Shelley.hs | 2 - lib/wallet/src/Cardano/Wallet.hs | 14 ++-- 3 files changed, 52 insertions(+), 43 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 fc464e0a93e..b2427f0400c 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 @@ -641,6 +641,8 @@ import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection import qualified Cardano.Wallet.Registry as Registry import qualified Cardano.Wallet.Write.Tx as WriteTx import qualified Control.Concurrent.Concierge as Concierge +import Control.Monad.Error.Class + ( throwError ) import qualified Data.ByteString as BS import qualified Data.Foldable as F import qualified Data.List as L @@ -1636,7 +1638,7 @@ selectCoins ctx@ApiLayer {..} genChange (ApiT wid) body = do wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + shelleyOnlyMkWithdrawal @s @k @n @'CredFromKeyK netLayer txLayer db wid era apiWdrl let outs = addressAmountToTxOut <$> body ^. #payments let txCtx = defaultTransactionCtx @@ -1739,7 +1741,7 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) = let db = wrk ^. typed @(DBLayer IO s k) era <- liftIO $ NW.currentNodeEra netLayer wdrl <- liftHandler $ ExceptT - $ W.unsafeShelleyMkSelfWithdrawal @s @k @_ @_ @n + $ W.shelleyOnlyMkSelfWithdrawal @s @k @_ @_ @n netLayer txLayer era db wid action <- liftIO $ W.validatedQuitStakePoolAction db wid wdrl @@ -1768,7 +1770,7 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) = liftHandler $ W.selectAssets @_ @_ @s @k @'CredFromKeyK wrk era pp selectAssetsParams transform (_, _, path) <- liftHandler - $ W.unsafeShelleyReadRewardAccount @s @k @n db wid + $ W.shelleyOnlyReadRewardAccount @s @k @n db wid let refund = W.stakeKeyDeposit pp pure $ mkApiCoinSelection [] [refund] (Just (action, path)) Nothing utx @@ -2005,8 +2007,9 @@ postTransactionOld ctx@ApiLayer{..} genChange (ApiT wid) body = do let outs = addressAmountToTxOut <$> body ^. #payments let md = body ^? #metadata . traverse . #txMetadataWithSchema_metadata let mTTL = body ^? #timeToLive . traverse . #getQuantity - - mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (body ^. #withdrawal) + mkRwdAcct <- case body ^. #withdrawal of + Nothing -> pure selfRewardAccountBuilder + Just w -> either liftE pure $ shelleyOnlyRewardAccountBuilder @s @_ @n w withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer era <- liftIO $ NW.currentNodeEra netLayer @@ -2014,7 +2017,7 @@ postTransactionOld ctx@ApiLayer{..} genChange (ApiT wid) body = do wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - unsafeShelleyMkWithdrawal @s @k @n + shelleyOnlyMkWithdrawal @s @k @n netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl @@ -2204,7 +2207,7 @@ postTransactionFeeOld ctx@ApiLayer{..} (ApiT wid) body = wdrl <- case body ^. #withdrawal of Nothing -> pure NoWithdrawal Just apiWdrl -> - unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + shelleyOnlyMkWithdrawal @s @k @n @'CredFromKeyK netLayer txLayer db wid era apiWdrl let txCtx = defaultTransactionCtx { txWithdrawal = wdrl @@ -2338,7 +2341,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of Just SelfWithdraw -> liftHandler - $ ExceptT $ W.unsafeShelleyMkSelfWithdrawal + $ ExceptT $ W.shelleyOnlyMkSelfWithdrawal @s @k @'CredFromKeyK @_ @n netLayer txLayer era db wid _ -> pure NoWithdrawal (deposit, refund, txCtx) <- case body ^. #delegations of @@ -2875,7 +2878,7 @@ decodeTransaction withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer (acct, _, acctPath) <- - liftHandler $ W.unsafeShelleyReadRewardAccount @s @k @n db wid + liftHandler $ W.shelleyOnlyReadRewardAccount @s @k @n db wid inputPaths <- liftHandler $ W.lookupTxIns @_ @s @k wrk wid $ fst <$> resolvedInputs @@ -3011,7 +3014,7 @@ submitTransaction ctx apiw@(ApiT wid) apitx = do _ <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer - (acct, _, path) <- liftHandler $ W.unsafeShelleyReadRewardAccount @s @k @n db wid + (acct, _, path) <- liftHandler $ W.shelleyOnlyReadRewardAccount @s @k @n db wid let wdrl = getOurWdrl acct path apiDecoded let txCtx = defaultTransactionCtx { -- TODO: [ADP-1193] @@ -3206,11 +3209,10 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do wrk era pp selectAssetsParams (const Prelude.id) sel' <- liftHandler $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel - mkRwdAcct <- mkRewardAccountBuilder @s @_ @n Nothing (tx, txMeta, txTime, sealedTx) <- liftHandler $ do let pwd = coerce $ getApiT $ body ^. #passphrase W.buildAndSignTransaction @_ @s @k - wrk wid era mkRwdAcct pwd txCtx sel' + wrk wid era selfRewardAccountBuilder pwd txCtx sel' liftHandler $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) mkApiTransaction (timeInterpreter (ctx ^. networkLayer)) @@ -3297,7 +3299,6 @@ quitStakePool -> ApiWalletPassphrase -> Handler (ApiTransaction n) quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do - mkRwdAcct <- mkRewardAccountBuilder @s @_ @n (Just SelfWithdrawal) withWorkerCtx ctx walletId liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO s k) notShelleyWallet = @@ -3333,7 +3334,7 @@ quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do (tx, txMeta, txTime, sealedTx) <- do let pwd = coerce $ getApiT $ body ^. #passphrase liftHandler $ W.buildAndSignTransaction @_ @s @k - wrk walletId era mkRwdAcct pwd txCtx sel' + wrk walletId era selfRewardAccountBuilder pwd txCtx sel' liftHandler $ W.submitTx @_ @s @k wrk walletId (tx, txMeta, sealedTx) mkApiTransaction ti wrk walletId #pendingSince @@ -3469,7 +3470,7 @@ createMigrationPlan ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = era <- liftIO $ NW.currentNodeEra netLayer rewardWithdrawal <- case withdrawalType of Nothing -> pure NoWithdrawal - Just pd -> unsafeShelleyMkWithdrawal @s @k @n @'CredFromKeyK + Just pd -> shelleyOnlyMkWithdrawal @s @k @n @'CredFromKeyK netLayer txLayer db wid era pd (wallet, _, _) <- liftHandler $ withExceptT ErrCreateMigrationPlanNoSuchWallet @@ -3561,13 +3562,17 @@ migrateWallet -> ApiWalletMigrationPostData n p -> Handler (NonEmpty (ApiTransaction n)) migrateWallet ctx@ApiLayer{..} withdrawalType (ApiT wid) postData = do - mkRewardAccount <- mkRewardAccountBuilder @s @_ @n withdrawalType + mkRewardAccount <- + case withdrawalType of + Nothing -> pure selfRewardAccountBuilder + Just w -> + either liftE pure $ shelleyOnlyRewardAccountBuilder @s @_ @n w withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. dbLayer era <- liftIO $ NW.currentNodeEra netLayer rewardWithdrawal <- case withdrawalType of Nothing -> pure NoWithdrawal - Just pd -> unsafeShelleyMkWithdrawal @s @k @n + Just pd -> shelleyOnlyMkWithdrawal @s @k @n netLayer txLayer db wid era pd plan <- liftHandler $ W.createMigrationPlan wrk era wid rewardWithdrawal ttl <- liftIO $ W.transactionExpirySlot ti Nothing @@ -3928,7 +3933,7 @@ mkWithdrawal netLayer txLayer db wallet era = \case -- | Unsafe version of `mkWithdrawal` that throws runtime error -- when applied to a non-shelley or non-sequential wallet state. -unsafeShelleyMkWithdrawal +shelleyOnlyMkWithdrawal :: forall s k (n :: NetworkDiscriminant) ktype tx . (Typeable n, Typeable s, Typeable k) => NetworkLayer IO Block @@ -3938,7 +3943,7 @@ unsafeShelleyMkWithdrawal -> AnyCardanoEra -> ApiWithdrawalPostData -> Handler Withdrawal -unsafeShelleyMkWithdrawal netLayer txLayer db wallet era postData = +shelleyOnlyMkWithdrawal netLayer txLayer db wallet era postData = case testEquality (typeRep @s) (typeRep @(SeqState n k)) of Nothing -> notShelleyWallet Just Refl -> case testEquality (typeRep @k) (typeRep @ShelleyKey) of @@ -3948,7 +3953,7 @@ unsafeShelleyMkWithdrawal netLayer txLayer db wallet era postData = notShelleyWallet = liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet -mkRewardAccountBuilder +shelleyOnlyRewardAccountBuilder :: forall s k (n :: NetworkDiscriminant) . ( HardDerivation k , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) @@ -3956,20 +3961,26 @@ mkRewardAccountBuilder , Typeable s , Typeable n ) - => Maybe ApiWithdrawalPostData - -> Handler (RewardAccountBuilder k) -mkRewardAccountBuilder withdrawal = do - let selfRewardCredentials (rootK, pwdP) = - (getRawKey (deriveRewardAccount @k pwdP rootK), pwdP) + => ApiWithdrawalPostData + -> Either ErrReadRewardAccount (RewardAccountBuilder k) +shelleyOnlyRewardAccountBuilder w = case testEquality (typeRep @s) (typeRep @(SeqState n ShelleyKey)) of - Nothing -> liftHandler $ throwE ErrReadRewardAccountNotAShelleyWallet - Just Refl -> case withdrawal of - Nothing -> pure selfRewardCredentials - Just w -> case w of - SelfWithdrawal -> pure selfRewardCredentials - ExternalWithdrawal (ApiMnemonicT m) -> do - let (xprv, _acct, _path) = W.someRewardAccount @ShelleyKey m - pure (const (xprv, mempty)) + Nothing -> throwError ErrReadRewardAccountNotAShelleyWallet + Just Refl -> case w of + SelfWithdrawal -> pure selfRewardAccountBuilder + ExternalWithdrawal (ApiMnemonicT m) -> do + let (xprv, _acct, _path) = W.someRewardAccount @ShelleyKey m + pure (const (xprv, mempty)) + +selfRewardAccountBuilder + :: forall k + . ( HardDerivation k + , Bounded (Index (AddressIndexDerivationType k) (AddressCredential k)) + , WalletKey k + ) + => RewardAccountBuilder k +selfRewardAccountBuilder (rootK, pwdP) = + (getRawKey (deriveRewardAccount @k pwdP rootK), pwdP) -- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'. mkApiCoinSelection @@ -4173,7 +4184,7 @@ mkApiTransaction timeInterpreter wrk wid timeRefLens tx = do -- using additional context from the 'WorkerCtx'. getApiAnyCertificates db ParsedTxCBOR{certificates} = do (rewardAccount, _, derivPath) <- liftHandler - $ W.unsafeShelleyReadRewardAccount @s @k @n db wid + $ W.shelleyOnlyReadRewardAccount @s @k @n db wid pure $ mkApiAnyCertificate rewardAccount derivPath <$> certificates depositIfAny :: Natural diff --git a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs index 6f617d85aec..635b8e61f3b 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Shelley.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Shelley.hs @@ -168,8 +168,6 @@ import Network.Wai.Handler.Warp ( setBeforeMainLoop ) import Ouroboros.Network.Client.Wallet ( PipeliningStrategy ) -import Servant.Server - ( ServerError ) import System.Exit ( ExitCode (..) ) import System.IOManager diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 3213441ceb2..74685e0e4a6 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -81,9 +81,9 @@ module Cardano.Wallet , checkWalletIntegrity , mkExternalWithdrawal , mkSelfWithdrawal - , unsafeShelleyMkSelfWithdrawal + , shelleyOnlyMkSelfWithdrawal , readRewardAccount - , unsafeShelleyReadRewardAccount + , shelleyOnlyReadRewardAccount , someRewardAccount , readPolicyPublicKey , writePolicyPublicKey @@ -1236,7 +1236,7 @@ mkSelfWithdrawal netLayer txLayer era db wallet = do -- | Unsafe version of the `mkSelfWithdrawal` function that throws an exception -- when applied to a non-shelley or a non-sequential wallet. -unsafeShelleyMkSelfWithdrawal +shelleyOnlyMkSelfWithdrawal :: forall s k ktype tx (n :: NetworkDiscriminant) . (Typeable s, Typeable k, Typeable n) => NetworkLayer IO Block @@ -1245,7 +1245,7 @@ unsafeShelleyMkSelfWithdrawal -> DBLayer IO s k -> WalletId -> IO (Either ErrWithdrawalNotWorth Withdrawal) -unsafeShelleyMkSelfWithdrawal netLayer txLayer era db wallet = +shelleyOnlyMkSelfWithdrawal netLayer txLayer era db wallet = case testEquality (typeRep @s) (typeRep @(SeqState n k)) of Nothing -> notShelleyWallet Just Refl -> case testEquality (typeRep @k) (typeRep @ShelleyKey) of @@ -1299,14 +1299,14 @@ readRewardAccount db wid = do -- | Unsafe version of the `readRewardAccount` function -- that throws error when applied to a non-sequential -- or a non-shelley wallet state. -unsafeShelleyReadRewardAccount +shelleyOnlyReadRewardAccount :: forall s k (n :: NetworkDiscriminant) . (Typeable s, Typeable n, Typeable k) => DBLayer IO s k -> WalletId -> ExceptT ErrReadRewardAccount IO (RewardAccount, XPub, NonEmpty DerivationIndex) -unsafeShelleyReadRewardAccount db wid = +shelleyOnlyReadRewardAccount db wid = case testEquality (typeRep @s) (typeRep @(SeqState n k)) of Nothing -> throwE ErrReadRewardAccountNotAShelleyWallet Just Refl -> @@ -2527,7 +2527,7 @@ constructTransaction -> ExceptT ErrConstructTx IO SealedTx constructTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do (_, xpub, _) <- withExceptT ErrConstructTxReadRewardAccount $ - unsafeShelleyReadRewardAccount @s @k @n db wid + shelleyOnlyReadRewardAccount @s @k @n db wid mapExceptT atomically $ do pp <- liftIO $ currentProtocolParameters nl withExceptT ErrConstructTxBody $ ExceptT $ pure $ From 7cdc038f99528c65c89f0c4e584b984e8a46bda9 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Wed, 9 Nov 2022 12:52:21 +0100 Subject: [PATCH 26/30] chore: reorder import --- lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 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 b2427f0400c..baa65fffd8e 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 @@ -520,6 +520,8 @@ import Control.Error.Util ( failWith ) import Control.Monad ( forM, forever, join, void, when, (<=<), (>=>) ) +import Control.Monad.Error.Class + ( throwError ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Trans.Except @@ -641,8 +643,6 @@ import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection import qualified Cardano.Wallet.Registry as Registry import qualified Cardano.Wallet.Write.Tx as WriteTx import qualified Control.Concurrent.Concierge as Concierge -import Control.Monad.Error.Class - ( throwError ) import qualified Data.ByteString as BS import qualified Data.Foldable as F import qualified Data.List as L From b1f330018d85456c74e52a82a864d491ccb636a0 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Wed, 9 Nov 2022 12:52:55 +0100 Subject: [PATCH 27/30] fix: zero reward is not worth withdrawing --- lib/wallet/src/Cardano/Wallet.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 74685e0e4a6..fdba70e4ca9 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1263,11 +1263,13 @@ checkRewardIsWorthTxCost -> Coin -> Either ErrWithdrawalNotWorth () checkRewardIsWorthTxCost txLayer pp era balance = do + when (balance == Coin 0) + $ Left ErrWithdrawalNotWorth let minimumCost txCtx = calcMinimumCost txLayer era pp txCtx emptySkeleton costWith = minimumCost $ mkTxCtx balance costWithout = minimumCost $ mkTxCtx $ Coin 0 - costOfWithdrawal = Coin.toInteger costWith - Coin.toInteger costWithout - when (Coin.toInteger balance < 2 * costOfWithdrawal) + worthOfWithdrawal = Coin.toInteger costWith - Coin.toInteger costWithout + when (Coin.toInteger balance < 2 * worthOfWithdrawal) $ Left ErrWithdrawalNotWorth where mkTxCtx wdrl = defaultTransactionCtx From c072c2bb086c18f6cfc3e375625c195fd2795fdb Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Fri, 11 Nov 2022 10:17:26 +0100 Subject: [PATCH 28/30] self withdrawal won't throw if its not worth --- .../http/Cardano/Wallet/Api/Http/Server.hs | 5 +++- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 27 +++++++++---------- lib/wallet/src/Cardano/Wallet.hs | 15 ++++++----- 3 files changed, 25 insertions(+), 22 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs index b1dee5f7d4d..2390a3ac3f1 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Server.hs @@ -338,7 +338,10 @@ server byron icarus shelley multisig spl ntp blockchainSource = shelleyTransactions :: Server (ShelleyTransactions n) shelleyTransactions = - constructTransaction shelley (delegationAddress @n) (knownPools spl) (getPoolLifeCycleStatus spl) + constructTransaction shelley + (delegationAddress @n) + (knownPools spl) + (getPoolLifeCycleStatus spl) :<|> signTransaction @_ @_ @_ @'CredFromKeyK shelley :<|> (\wid mMinWithdrawal mStart mEnd mOrder simpleMetadataFlag -> 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 baa65fffd8e..994d6fdd938 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 @@ -1740,9 +1740,9 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) = withWorkerCtx ctx wid liftE liftE $ \wrk -> do let db = wrk ^. typed @(DBLayer IO s k) era <- liftIO $ NW.currentNodeEra netLayer - wdrl <- liftHandler $ ExceptT - $ W.shelleyOnlyMkSelfWithdrawal @s @k @_ @_ @n - netLayer txLayer era db wid + wdrl <- + liftIO $ W.shelleyOnlyMkSelfWithdrawal + @_ @_ @_ @_ @n netLayer txLayer era db wid action <- liftIO $ W.validatedQuitStakePoolAction db wid wdrl let txCtx = defaultTransactionCtx @@ -2238,8 +2238,8 @@ postTransactionFeeOld ctx@ApiLayer{..} (ApiT wid) body = liftHandler $ mkApiFee Nothing minCoins <$> W.estimateFee runSelection constructTransaction - :: forall ctx s k n. - ( ctx ~ ApiLayer s k 'CredFromKeyK + :: forall ctx s k n ktype. + ( ctx ~ ApiLayer s k ktype , GenChange s , HasNetworkLayer IO ctx , IsOurs s Address @@ -2340,9 +2340,9 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do pp <- liftIO $ NW.currentProtocolParameters netLayer era <- liftIO $ NW.currentNodeEra netLayer wdrl <- case body ^. #withdrawal of - Just SelfWithdraw -> liftHandler - $ ExceptT $ W.shelleyOnlyMkSelfWithdrawal - @s @k @'CredFromKeyK @_ @n netLayer txLayer era db wid + Just SelfWithdraw -> + liftIO $ W.shelleyOnlyMkSelfWithdrawal @s @k @ktype @_ @n + netLayer txLayer era db wid _ -> pure NoWithdrawal (deposit, refund, txCtx) <- case body ^. #delegations of Nothing -> pure (Nothing, Nothing, defaultTransactionCtx @@ -2439,7 +2439,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do pure (txCtx, Nothing) let runSelection outs = - W.selectAssets @_ @_ @s @k @'CredFromKeyK + W.selectAssets @_ @_ @s @k @ktype wrk era pp selectAssetsParams transform where selectAssetsParams = W.SelectAssetsParams @@ -2481,12 +2481,12 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do pure (sel, sel', estMin) tx <- liftHandler - $ W.constructTransaction @_ @s @k @n wrk wid era txCtx' sel + $ W.constructTransaction @_ @s @k @n @ktype wrk wid era txCtx' sel pure ApiConstructTransaction { transaction = case body ^. #encoding of - Just HexEncoded -> ApiSerialisedTransaction (ApiT tx) HexEncoded - _ -> ApiSerialisedTransaction (ApiT tx) Base64Encoded + Just HexEncoded -> ApiSerialisedTransaction (ApiT tx) HexEncoded + _ -> ApiSerialisedTransaction (ApiT tx) Base64Encoded , coinSelection = mkApiCoinSelection (maybeToList deposit) (maybeToList refund) Nothing md sel' , fee = Quantity $ fromIntegral fee @@ -3925,8 +3925,7 @@ mkWithdrawal -> Handler Withdrawal mkWithdrawal netLayer txLayer db wallet era = \case SelfWithdrawal -> - liftHandler . ExceptT - $ W.mkSelfWithdrawal netLayer txLayer era db wallet + liftIO $ W.mkSelfWithdrawal netLayer txLayer era db wallet ExternalWithdrawal (ApiMnemonicT mnemonic) -> liftHandler . ExceptT $ W.mkExternalWithdrawal netLayer txLayer era mnemonic diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index fdba70e4ca9..7126878ce26 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1224,15 +1224,16 @@ mkSelfWithdrawal -> AnyCardanoEra -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey -> WalletId - -> IO (Either ErrWithdrawalNotWorth Withdrawal) + -> IO Withdrawal mkSelfWithdrawal netLayer txLayer era db wallet = do (rewardAccount, _, derivationPath) <- runExceptT (readRewardAccount db wallet) >>= either (throwIO . ExceptionReadRewardAccount) pure balance <- getCachedRewardAccountBalance netLayer rewardAccount pp <- currentProtocolParameters netLayer - pure $ checkRewardIsWorthTxCost txLayer pp era balance $> - WithdrawalSelf rewardAccount derivationPath balance + pure $ WithdrawalSelf rewardAccount derivationPath + $ either (\_notWorth -> Coin 0) (\_worth -> balance) + $ checkRewardIsWorthTxCost txLayer pp era balance -- | Unsafe version of the `mkSelfWithdrawal` function that throws an exception -- when applied to a non-shelley or a non-sequential wallet. @@ -1244,7 +1245,7 @@ shelleyOnlyMkSelfWithdrawal -> AnyCardanoEra -> DBLayer IO s k -> WalletId - -> IO (Either ErrWithdrawalNotWorth Withdrawal) + -> IO Withdrawal shelleyOnlyMkSelfWithdrawal netLayer txLayer era db wallet = case testEquality (typeRep @s) (typeRep @(SeqState n k)) of Nothing -> notShelleyWallet @@ -2513,8 +2514,8 @@ buildAndSignTransaction ctx wid era mkRwdAcct pwd txCtx sel = db & \DBLayer{..} -- | Construct an unsigned transaction from a given selection. constructTransaction - :: forall ctx s k (n :: NetworkDiscriminant). - ( HasTransactionLayer k 'CredFromKeyK ctx + :: forall ctx s k (n :: NetworkDiscriminant) ktype. + ( HasTransactionLayer k ktype ctx , HasDBLayer IO s k ctx , HasNetworkLayer IO ctx , Typeable s @@ -2536,7 +2537,7 @@ constructTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do mkUnsignedTransaction tl era xpub pp txCtx sel where db = ctx ^. dbLayer @IO @s @k - tl = ctx ^. transactionLayer @k @'CredFromKeyK + tl = ctx ^. transactionLayer @k @ktype nl = ctx ^. networkLayer -- | Construct an unsigned transaction from a given selection From eee226946aacc5267e6aece901d561c9baed1cb8 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Fri, 11 Nov 2022 18:08:42 +0100 Subject: [PATCH 29/30] fixup! remove unnecessary polymorphism --- lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 994d6fdd938..0210ca8a162 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 @@ -1072,7 +1072,7 @@ mkSharedWallet , Shared.SupportsDiscovery n k ) => MkApiWallet ctx s ApiSharedWallet -mkSharedWallet ctx@ApiLayer{..} wid cp meta delegation pending progress = +mkSharedWallet ctx wid cp meta delegation pending progress = case Shared.ready st of Shared.Pending -> pure $ ApiSharedWallet $ Left $ ApiPendingSharedWallet { id = ApiT wid From 611652818e4ed4b05f556b943df92b3dd06dd375 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Sun, 13 Nov 2022 10:31:09 +0100 Subject: [PATCH 30/30] Touch CI --- touch.me.CI | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/touch.me.CI b/touch.me.CI index 5f5305e97d8..448c9758258 100644 --- a/touch.me.CI +++ b/touch.me.CI @@ -1 +1 @@ -Mon Oct 31 05:53:56 PM CET 2022 +Sun Nov 13 10:30:56 AM CET 2022