diff --git a/lib/core-integration/src/Test/Integration/Faucet.hs b/lib/core-integration/src/Test/Integration/Faucet.hs
index f851e85fe4d..901a64d5768 100644
--- a/lib/core-integration/src/Test/Integration/Faucet.hs
+++ b/lib/core-integration/src/Test/Integration/Faucet.hs
@@ -20,6 +20,10 @@ module Test.Integration.Faucet
, mirMnemonics
, maMnemonics
+ -- * Dust wallets
+ , bigDustWallet
+ , onlyDustWallet
+
-- * Sea horses
, seaHorseTokenName
, seaHorsePolicyId
diff --git a/lib/core-integration/src/Test/Integration/Framework/TestData.hs b/lib/core-integration/src/Test/Integration/Framework/TestData.hs
index e92af78228f..66614822215 100644
--- a/lib/core-integration/src/Test/Integration/Framework/TestData.hs
+++ b/lib/core-integration/src/Test/Integration/Framework/TestData.hs
@@ -353,10 +353,13 @@ errMsg400MinWithdrawalWrong = "The minimum withdrawal value must be at least \
\1 Lovelace."
errMsg403NothingToMigrate :: Text -> String
-errMsg403NothingToMigrate wid =
- "I can't migrate the wallet with the given id: " ++ unpack wid ++
- ", because it's either empty or full of small coins which wouldn't be \
- \worth migrating."
+errMsg403NothingToMigrate _wid = mconcat
+ [ "I wasn't able to construct a migration plan. This could be "
+ , "because your wallet is empty, or it could be because the "
+ , "amount of ada in your wallet is insufficient to pay for "
+ , "any of the funds to be migrated. Try adding some ada to "
+ , "your wallet before trying again."
+ ]
errMsg404NoAsset :: String
errMsg404NoAsset = "The requested asset is not associated with this wallet."
diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Byron/Migrations.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Byron/Migrations.hs
index 8bc79ec784f..0a9081f2c38 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Byron/Migrations.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Byron/Migrations.hs
@@ -48,6 +48,8 @@ import Control.Monad.IO.Class
( liftIO )
import Control.Monad.Trans.Resource
( runResourceT )
+import Data.Functor
+ ( (<&>) )
import Data.Generics.Internal.VL.Lens
( view, (^.) )
import Data.Maybe
@@ -61,7 +63,7 @@ import Data.Text
import Data.Word
( Word64 )
import Test.Hspec
- ( SpecWith, describe, pendingWith, shouldBe, shouldSatisfy )
+ ( SpecWith, describe, shouldBe, shouldSatisfy )
import Test.Hspec.Extra
( it )
import Test.Integration.Framework.DSL
@@ -115,370 +117,460 @@ spec :: forall n.
, PaymentAddress n ByronKey
) => SpecWith Context
spec = describe "BYRON_MIGRATIONS" $ do
- it "BYRON_CALCULATE_01 - \
- \for non-empty wallet calculated fee is > zero."
+
+ it "BYRON_CREATE_MIGRATION_PLAN_01 - \
+ \Can create a migration plan."
$ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
$ \fixtureByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- fixtureByronWallet ctx
- let ep = Link.createMigrationPlan @'Byron w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- verify r
- [ expectResponseCode HTTP.status200
+ sourceWallet <- fixtureByronWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Byron sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
+ [ expectResponseCode HTTP.status202
, expectField (#totalFee . #getQuantity)
- (.> 0)
+ (`shouldBe` 334_200)
+ , expectField (#selections)
+ ((`shouldBe` 1) . length)
+ , expectField (#balanceSelected . #ada . #getQuantity)
+ (`shouldBe` 1_000_000_000_000)
+ , expectField (#balanceLeftover . #ada . #getQuantity)
+ (`shouldBe` 0)
]
- it "BYRON_CALCULATE_02 - \
- \Cannot calculate fee for empty wallet."
+ it "BYRON_CREATE_MIGRATION_PLAN_02 - \
+ \Cannot create plan for empty wallet."
$ \ctx -> forM_ [emptyRandomWallet, emptyIcarusWallet]
$ \emptyByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- emptyByronWallet ctx
- let ep = Link.createMigrationPlan @'Byron w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- verify r
+ sourceWallet <- emptyByronWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Byron sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
[ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate $ w ^. walletId)
+ , expectErrorMessage
+ (errMsg403NothingToMigrate $ sourceWallet ^. walletId)
+ ]
+
+ it "BYRON_CREATE_MIGRATION_PLAN_03 - \
+ \Cannot create plan for Shelley wallet using Byron endpoint."
+ $ \ctx -> runResourceT $ do
+ sourceWallet <- emptyWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Byron sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
+ [ expectResponseCode HTTP.status404
+ , expectErrorMessage
+ (errMsg404NoWallet $ sourceWallet ^. walletId)
]
- it "BYRON_CALCULATE_02 - \
- \Cannot calculate fee for wallet with dust, that cannot be migrated."
+ it "BYRON_CREATE_MIGRATION_PLAN_04 - \
+ \Cannot create a plan for a wallet that only contains dust."
$ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- NOTE
- -- Special mnemonic for which wallet with dust
- -- (5 utxo with 60 lovelace)
- let mnemonics =
- ["suffer", "decorate", "head", "opera", "yellow", "debate"
- , "visa", "fire", "salute", "hybrid", "stone", "smart"] :: [Text]
+ -- NOTE:
+ -- Special mnemonic for wallet that has dust
+ -- (5 UTxOs with 60 lovelace each)
+ let mnemonicSentence =
+ [ "suffer", "decorate", "head", "opera", "yellow", "debate"
+ , "visa", "fire", "salute", "hybrid", "stone", "smart"
+ ] :: [Text]
let payloadRestore = Json [json| {
"name": "Dust Byron Wallet",
- "mnemonic_sentence": #{mnemonics},
+ "mnemonic_sentence": #{mnemonicSentence},
"passphrase": #{fixturePassphrase},
"style": "random"
} |]
- w <- unsafeResponse <$> postByronWallet ctx payloadRestore
- let ep = Link.createMigrationPlan @'Byron w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- verify r
+ sourceWallet <- unsafeResponse <$>
+ postByronWallet ctx payloadRestore
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Byron sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
[ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate $ w ^. walletId)
+ , expectErrorMessage
+ (errMsg403NothingToMigrate $ sourceWallet ^. walletId)
]
- it "BYRON_CALCULATE_03 - \
- \Cannot estimate migration for Shelley wallet using Byron endpoint"
- $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- emptyWallet ctx
- let ep = Link.createMigrationPlan @'Byron w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- expectResponseCode HTTP.status404 r
- expectErrorMessage (errMsg404NoWallet $ w ^. walletId) r
-
- describe "BYRON_MIGRATE_05 - I could migrate to any valid address" $ do
- forM_ [ ("Byron", emptyRandomWallet)
- , ("Icarus", emptyIcarusWallet)
- ] $ \(walType, destWallet) -> do
-
- it ("From wallet type: " ++ walType) $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- --shelley address
- wShelley <- emptyWallet ctx
- addrs <- listAddresses @n ctx wShelley
- let addrShelley = (addrs !! 1) ^. #id
- --icarus address
- addrIcarus <- liftIO $ encodeAddress @n . head . icarusAddresses @n
- . entropyToMnemonic @15 <$> genEntropy
- --byron address
- addrByron <- liftIO $ encodeAddress @n . head . randomAddresses @n
- . entropyToMnemonic @12 <$> genEntropy
+ it "BYRON_CREATE_MIGRATION_PLAN_05 - \
+ \Creating a plan is deterministic."
+ $ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
+ $ \fixtureByronWallet -> runResourceT $ do
+ sourceWallet <- fixtureByronWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Byron sourceWallet
+ response1 <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ response2 <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ expectResponseCode HTTP.status202 response1
+ expectResponseCode HTTP.status202 response2
+ expectField (#selections) ((.> 0) . length) response1
+ expectField (#selections) ((.> 0) . length) response2
+ case (snd response1, snd response2) of
+ (Right plan1, Right plan2) ->
+ liftIO $ plan1 `shouldBe` plan2
+ _ ->
+ error "Unable to compare plans."
+
+ describe "BYRON_MIGRATE_01 - \
+ \After a migration operation successfully completes, the correct \
+ \amounts eventually become available in the target wallet for an \
+ \arbitrary number of specified addresses, and the balance of the \
+ \source wallet is completely depleted."
+ $ do
+ testAddressCycling "Random" fixtureRandomWallet 1
+ testAddressCycling "Random" fixtureRandomWallet 3
+ testAddressCycling "Random" fixtureRandomWallet 10
+ testAddressCycling "Icarus" fixtureIcarusWallet 1
+ testAddressCycling "Icarus" fixtureIcarusWallet 3
+ testAddressCycling "Icarus" fixtureIcarusWallet 10
- sWallet <- destWallet ctx
- r <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Byron sWallet)
- Default
- (Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addrShelley}, #{addrIcarus}, #{addrByron}]
- }|])
- verify r
- [ expectResponseCode HTTP.status403
- , expectErrorMessage
- (errMsg403NothingToMigrate (sWallet ^. walletId))
- ]
+ Hspec.it "BYRON_MIGRATE_02 - \
+ \Can migrate a large wallet requiring more than one transaction."
+ $ \ctx -> runResourceT @IO $ do
- it "BYRON_MIGRATE_07 - invalid payload, parser error" $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- sourceWallet <- emptyRandomWallet ctx
-
- r <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Byron sourceWallet)
- Default
- (NonJson "{passphrase:,}")
- expectResponseCode HTTP.status400 r
- expectErrorMessage errMsg400ParseError r
-
- it "BYRON_MIGRATE_01 - \
- \after a migration operation successfully completes, the correct \
- \amount eventually becomes available in the target wallet for arbitrary \
- \ number of specified addresses."
- $ \ctx -> runResourceT $ do
- testAddressCycling ctx 1
- testAddressCycling ctx 3
- testAddressCycling ctx 10
-
- Hspec.it "BYRON_MIGRATE_01 - \
- \ migrate a big wallet requiring more than one tx" $ \ctx -> runResourceT @IO $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- NOTE
- -- Special mnemonic for which 200 legacy funds are attached to in the
+ -- NOTE:
+ --
+ -- Special mnemonic to which 200 legacy coins are attached in the
-- genesis file.
--
- -- Out of these 200 coins, 100 of them are of 1 Lovelace and are
- -- expected to be treated as dust. The rest are all worth:
- -- 10,000,000,000 lovelace.
- let mnemonics =
+ -- Out of these 200 coins:
+ --
+ -- - 100 coins are each worth 1 lovelace, and are expected to be
+ -- treated as dust.
+ -- - 100 coins are each worth 10,000,000,000 lovelace.
+ --
+ let sourceWalletMnemonic =
["collect", "fold", "file", "clown"
, "injury", "sun", "brass", "diet"
, "exist", "spike", "behave", "clip"
] :: [Text]
- let payloadRestore = Json [json| {
+ sourceWallet <- unsafeResponse <$> postByronWallet ctx
+ (Json [json|{
"name": "Big Byron Wallet",
- "mnemonic_sentence": #{mnemonics},
+ "mnemonic_sentence": #{sourceWalletMnemonic},
"passphrase": #{fixturePassphrase},
"style": "random"
- } |]
- wOld <- unsafeResponse <$> postByronWallet ctx payloadRestore
- originalBalance <- eventually "wallet balance greater than 0" $ do
- r <- request @ApiByronWallet ctx
- (Link.getWallet @'Byron wOld)
- Default
- Empty
- verify r
- [ expectField (#balance . #available) (.> Quantity 0)
+ }|])
+ sourceBalance <- eventually "Source wallet balance is correct." $ do
+ response <- request @ApiByronWallet ctx
+ (Link.getWallet @'Byron sourceWallet) Default Empty
+ verify response
+ [ expectField (#balance . #available . #getQuantity)
+ (`shouldBe` 1_000_000_000_100)
]
- return $ getFromResponse (#balance . #available . #getQuantity) r
-
- --Calculate the expected migration fee:
- rFee <- request @(ApiWalletMigrationPlan n) ctx
- (Link.createMigrationPlan @'Byron wOld)
- Default
- Empty
- verify rFee
- [ expectResponseCode HTTP.status200
- , expectField #totalFee (.> Quantity 0)
+ return $ getFromResponse
+ (#balance . #available . #getQuantity) response
+
+ -- Create an empty target wallet:
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Compute the expected migration plan:
+ responsePlan <- request @(ApiWalletMigrationPlan n) ctx
+ (Link.createMigrationPlan @'Byron sourceWallet) Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify responsePlan
+ [ expectResponseCode HTTP.status202
+ , expectField
+ (#totalFee . #getQuantity)
+ (`shouldBe` 2_460_400)
+ , expectField
+ (#selections)
+ ((`shouldBe` 2) . length)
+ , expectField
+ (#balanceLeftover . #ada . #getQuantity)
+ (`shouldBe` 100)
+ , expectField
+ (#balanceSelected . #ada . #getQuantity)
+ (`shouldBe` 1_000_000_000_000)
]
- let expectedFee =
- getFromResponse (#totalFee . #getQuantity) rFee
- let balanceLeftover =
- getFromResponse (#balanceLeftover . #ada . #getQuantity) rFee
-
- -- Migrate to a new empty wallet
- wNew <- emptyWallet ctx
- addrs <- listAddresses @n ctx wNew
- let addr1 = (addrs !! 1) ^. #id
-
- -- NOTE
- -- The migration typically involves many transactions being sent one by
- -- one. It may happen that one of these transaction is rolled back and
- -- simply discarded entirely from mem pools. There's no retry mechanism
- -- from the wallet _yet_, which means that such transactions must be
- -- manually retried by clients.
+ let expectedFee = getFromResponse
+ (#totalFee . #getQuantity) responsePlan
+ let balanceLeftover =getFromResponse
+ (#balanceLeftover . #ada . #getQuantity) responsePlan
+
+ -- Perform a migration from the source wallet to the target wallet.
--
- -- This 'migrateWallet' function does exactly this, and will try to make
- -- sure that rolledback functions are canceled and retried up until the
- -- full migration is done.
- liftIO $ migrateWallet ctx wOld [addr1]
-
- -- Check that funds become available in the target wallet: Because
- -- there's a bit of non-determinism in how the migration is really done,
- -- we can expect the final balance with exactitude. Yet, we still expect
- -- it to be not too far away from an ideal value.
- let expectedMinBalance =
- originalBalance - 2 * expectedFee - balanceLeftover
- eventually "wallet balance ~ expectedBalance" $ do
- request @ApiWallet ctx
- (Link.getWallet @'Shelley wNew)
- Default
- Empty >>= flip verify
+ -- This migration will involve more than one transaction, where each
+ -- transaction is sent one by one. It may happen that one of these
+ -- transactions is rolled back or simply discarded entirely. The wallet
+ -- doesn't currently have any retry mechanism, which means that
+ -- transactions must be manually retried by clients.
+ --
+ -- The 'migrateWallet' function tries do exactly that: to make sure
+ -- that rolled-back transactions are cancelled and retried until the
+ -- migration is complete.
+ --
+ liftIO $ migrateWallet ctx sourceWallet targetAddressIds
+
+ -- Check that funds become available in the target wallet.
+ let expectedTargetBalance =
+ sourceBalance - balanceLeftover - expectedFee
+ eventually "Target wallet balance reaches expected balance" $ do
+ response <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley targetWallet) Default Empty
+ verify response
[ expectField
- (#balance . #available)
- (.> (Quantity expectedMinBalance))
+ (#balance . #available . #getQuantity)
+ (`shouldBe` expectedTargetBalance)
, expectField
- (#balance . #total)
- (.> (Quantity expectedMinBalance))
+ (#balance . #total . #getQuantity)
+ (`shouldBe` expectedTargetBalance)
]
- -- Analyze the target wallet UTxO distribution
- request @ApiUtxoStatistics ctx (Link.getUTxOsStatistics @'Shelley wNew)
- Default
- Empty >>= flip verify
+ -- Analyse the target wallet's UTxO distribution:
+ responseStats <- request @ApiUtxoStatistics ctx
+ (Link.getUTxOsStatistics @'Shelley targetWallet) Default Empty
+ verify responseStats
[ expectField
- #distribution
- ((`shouldBe` (Just 100)) . Map.lookup 10_000_000_000)
+ (#distribution)
+ ((`shouldBe` (Just 2)) . Map.lookup 1_000_000_000_000)
]
- it "BYRON_MIGRATE_01 - \
- \a migration operation removes all funds from the source wallet."
+ -- Check that the source wallet has the expected leftover balance:
+ responseFinalSourceBalance <- request @ApiByronWallet ctx
+ (Link.getWallet @'Byron sourceWallet) Default Empty
+ verify responseFinalSourceBalance
+ [ expectResponseCode HTTP.status200
+ , expectField (#balance . #available)
+ (`shouldBe` Quantity 100)
+ , expectField (#balance . #total)
+ (`shouldBe` Quantity 100)
+ ]
+
+ it "BYRON_MIGRATE_03 - \
+ \Migrating an empty wallet should fail."
+ $ \ctx -> forM_ [emptyRandomWallet, emptyIcarusWallet]
+ $ \emptyByronWallet -> runResourceT $ do
+ sourceWallet <- emptyByronWallet ctx
+ let sourceWalletId = sourceWallet ^. walletId
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.migrateWallet @'Byron sourceWallet
+ response <- request @[ApiTransaction n] ctx ep Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage (errMsg403NothingToMigrate sourceWalletId)
+ ]
+
+ Hspec.it "BYRON_MIGRATE_04 - \
+ \Actual fee for migration is identical to predicted fee."
+ $ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
+ $ \fixtureByronWallet -> runResourceT @IO $ do
+
+ let feeExpected = 334_200
+
+ -- Restore a source wallet with funds.
+ sourceWallet <- fixtureByronWallet ctx
+
+ -- Create an empty target wallet:
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Create a migration plan:
+ let endpointPlan = (Link.createMigrationPlan @'Byron sourceWallet)
+ responsePlan <- request @(ApiWalletMigrationPlan n)
+ ctx endpointPlan Default $
+ Json [json|{addresses: #{targetAddressIds}}|]
+ verify responsePlan
+ [ expectResponseCode HTTP.status202
+ , expectField #totalFee (`shouldBe` Quantity feeExpected)
+ , expectField #selections ((`shouldBe` 1) . length)
+ ]
+
+ -- Perform a migration:
+ let endpointMigrate = Link.migrateWallet @'Byron sourceWallet
+ responseMigrate <-
+ request @[ApiTransaction n] ctx endpointMigrate Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
+ -- Verify the fee is as expected:
+ verify responseMigrate
+ [ expectResponseCode HTTP.status202
+ , expectField id ((`shouldBe` 1) . length)
+ , expectField id
+ $ (`shouldBe` feeExpected)
+ . fromIntegral
+ . sum
+ . fmap apiTransactionFee
+ ]
+
+ it "BYRON_MIGRATE_05 - \
+ \Migration fails if the wrong passphrase is supplied."
$ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
$ \fixtureByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
+
-- Restore a Byron wallet with funds, to act as a source wallet:
sourceWallet <- fixtureByronWallet ctx
- -- Perform a migration from the source wallet to a target wallet:
+ -- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
- r0 <- request @[ApiTransaction n] ctx
+ -- Attempt to perform a migration:
+ response <- request @[ApiTransaction n] ctx
(Link.migrateWallet @'Byron sourceWallet)
Default
(Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
+ { passphrase: "not-the-right-passphrase"
+ , addresses: #{targetAddressIds}
}|])
- verify r0
- [ expectResponseCode HTTP.status202
- , expectField id (`shouldSatisfy` (not . null))
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage errMsg403WrongPass
]
- -- Verify that the source wallet has no funds available:
- r1 <- request @ApiByronWallet ctx
- (Link.getWallet @'Byron sourceWallet) Default Empty
- verify r1
- [ expectResponseCode HTTP.status200
- , expectField (#balance . #available) (`shouldBe` Quantity 0)
- ]
+ describe "BYRON_MIGRATE_06 - \
+ \It's possible to migrate to any valid address."
+ $ forM_
+ [ ("Random", emptyRandomWallet)
+ , ("Icarus", emptyIcarusWallet)
+ ] $ \(walType, destWallet) ->
- it "BYRON_MIGRATE_02 - \
- \migrating an empty wallet should fail."
- $ \ctx -> forM_ [emptyRandomWallet, emptyIcarusWallet]
- $ \emptyByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- sourceWallet <- emptyByronWallet ctx
- targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
- Json [json|
+ it ("From wallet type: " ++ walType) $ \ctx -> runResourceT $ do
+
+ -- Create a Shelley address:
+ wShelley <- emptyWallet ctx
+ addrs <- listAddresses @n ctx wShelley
+ let addrShelley = (addrs !! 1) ^. #id
+
+ -- Create an Icarus address:
+ addrIcarus <- liftIO $ encodeAddress @n
+ . head
+ . icarusAddresses @n
+ . entropyToMnemonic @15 <$> genEntropy
+
+ -- Create a Byron address:
+ addrByron <- liftIO $ encodeAddress @n
+ . head
+ . randomAddresses @n
+ . entropyToMnemonic @12 <$> genEntropy
+
+ -- Create a source wallet:
+ sourceWallet <- destWallet ctx
+
+ -- Initiate a migration to all address types:
+ response <- request @[ApiTransaction n] ctx
+ (Link.migrateWallet @'Byron sourceWallet) Default
+ (Json [json|
{ passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
- }|]
- let ep = Link.migrateWallet @'Byron sourceWallet
- r <- request @[ApiTransaction n] ctx ep Default payload
- let srcId = sourceWallet ^. walletId
- verify r
- [ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate srcId)
+ , addresses:
+ [ #{addrShelley}
+ , #{addrIcarus}
+ , #{addrByron}
+ ]
+ }|])
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage
+ (errMsg403NothingToMigrate (sourceWallet ^. walletId))
+ ]
+
+ it "BYRON_MIGRATE_07 - \
+ \Including an invalidly-formatted passphrase results in a parser error."
+ $ \ctx -> runResourceT $ do
+ sourceWallet <- emptyRandomWallet ctx
+ response <- request @[ApiTransaction n] ctx
+ (Link.migrateWallet @'Byron sourceWallet) Default
+ (NonJson "{passphrase:,}")
+ verify response
+ [ expectResponseCode HTTP.status400
+ , expectErrorMessage errMsg400ParseError
]
- Hspec.it "BYRON_MIGRATE_02 - \
- \migrating wallet with dust should fail."
+ Hspec.it "BYRON_MIGRATE_08 - \
+ \It's not possible to migrate a wallet whose total balance is less \
+ \than the minimum ada quantity for an output."
$ \ctx -> runResourceT @IO $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- NOTE
- -- Special mnemonic for which wallet with dust
- -- (5 utxos with 60 lovelace in total)
- let mnemonics =
+
+ -- Create a source wallet with a small number of small quantities:
+ let mnemonicSentence =
[ "suffer", "decorate", "head", "opera"
, "yellow", "debate", "visa", "fire"
, "salute", "hybrid", "stone", "smart"
] :: [Text]
- let payloadRestore = Json [json| {
+ sourceWallet <- unsafeResponse <$> postByronWallet ctx
+ (Json [json|{
"name": "Dust Byron Wallet",
- "mnemonic_sentence": #{mnemonics},
+ "mnemonic_sentence": #{mnemonicSentence},
"passphrase": #{fixturePassphrase},
"style": "random"
- } |]
- sourceWallet <- unsafeResponse <$> postByronWallet ctx payloadRestore
- eventually "wallet balance greater than 0" $ do
+ }|])
+ eventually "Source wallet balance is correct." $ do
request @ApiByronWallet ctx
(Link.getWallet @'Byron sourceWallet)
Default
Empty >>= flip verify
- [ expectField (#balance . #available) (.> Quantity 0)
+ [ expectField (#balance . #available)
+ (`shouldBe` Quantity 15)
]
-
- targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
- Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
- }|]
- let ep = Link.migrateWallet @'Byron sourceWallet
- r <- request @[ApiTransaction n] ctx ep Default payload
- let srcId = sourceWallet ^. walletId
- verify r
- [ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate srcId)
- ]
-
- it "BYRON_MIGRATE_03 - \
- \actual fee for migration is the same as the predicted fee."
- $ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
- $ \fixtureByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- Restore a Byron wallet with funds.
- sourceWallet <- fixtureByronWallet ctx
-
- -- Request a migration fee prediction.
- let ep0 = (Link.createMigrationPlan @'Byron sourceWallet)
- r0 <- request @(ApiWalletMigrationPlan n) ctx ep0 Default Empty
- verify r0
- [ expectResponseCode HTTP.status200
- , expectField #totalFee (.> Quantity 0)
+ let sourceWalletId = sourceWallet ^. walletId
+
+ -- Analyse the source wallet's UTxO distribution:
+ let expectedSourceDistribution = [(10, 5)]
+ responseSourceDistribution <- request @ApiUtxoStatistics ctx
+ (Link.getUTxOsStatistics @'Byron sourceWallet) Default Empty
+ verify responseSourceDistribution
+ [ expectField #distribution
+ ((`shouldBe` expectedSourceDistribution)
+ . Map.toList
+ . Map.filter (> 0)
+ )
]
- -- Perform the migration.
+ -- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
- Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
- }|]
- let ep1 = Link.migrateWallet @'Byron sourceWallet
- r1 <- request @[ApiTransaction n] ctx ep1 Default payload
- verify r1
- [ expectResponseCode HTTP.status202
- , expectField id (`shouldSatisfy` (not . null))
- ]
-
- -- Verify that the fee prediction was correct.
- let actualFee = fromIntegral $ sum $ apiTransactionFee
- <$> getFromResponse id r1
- let predictedFee =
- getFromResponse (#totalFee . #getQuantity) r0
- liftIO $ actualFee `shouldBe` predictedFee
-
- it "BYRON_MIGRATE_04 - migration fails with a wrong passphrase"
- $ \ctx -> forM_ [fixtureRandomWallet, fixtureIcarusWallet]
- $ \fixtureByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- Restore a Byron wallet with funds, to act as a source wallet:
- sourceWallet <- fixtureByronWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
- -- Perform a migration from the source wallet to a target wallet:
- targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- r0 <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Byron sourceWallet)
- Default
- (Json [json|
- { passphrase: "not-the-right-passphrase"
- , addresses: [#{addr1}]
- }|])
- verify r0
- [ expectResponseCode HTTP.status403
- , expectErrorMessage errMsg403WrongPass
- ]
+ -- Attempt a migration:
+ let ep = Link.migrateWallet @'Byron sourceWallet
+ responseMigrate <- request @[ApiTransaction n] ctx ep Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
+ verify responseMigrate
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage (errMsg403NothingToMigrate sourceWalletId)
+ ]
where
-- Compute the fee associated with an API transaction.
apiTransactionFee :: ApiTransaction n -> Word64
@@ -501,33 +593,41 @@ spec = describe "BYRON_MIGRATIONS" $ do
-> [(ApiT Address, Proxy n)]
-> IO ()
migrateWallet ctx src targets = do
- (st, _) <- request
- @(ApiWalletMigrationPlan n) ctx endpointInfo Default Empty
- when (st == HTTP.status200) $ do -- returns '403 Nothing to Migrate' when done
- -- 1/ Forget all pending transactions to unlock any locked UTxO
- (_, txs) <- unsafeRequest @[ApiTransaction n] ctx endpointListTxs Empty
+ (status, _) <- request @(ApiWalletMigrationPlan n) ctx
+ endpointCreateMigrationPlan Default payloadCreateMigrationPlan
+ when (status == HTTP.status202) $ do
+ -- The above request returns '403 Nothing to Migrate' when done.
+
+ -- 1. Forget all pending transactions to unlock any locked UTxO:
+ (_, txs) <- unsafeRequest
+ @[ApiTransaction n] ctx endpointListTxs Empty
forM_ txs $ forgetTxIf ((== ApiT Pending) . view #status)
- -- 2/ Attempt to migrate
- _ <- request @[ApiTransaction n] ctx endpointMigration Default payload
+ -- 2. Attempt to migrate:
+ _ <- request @[ApiTransaction n] ctx endpointMigrateWallet Default
+ payloadMigrateWallet
- -- 3/ Wait "long-enough" for transactions to have been inserted.
+ -- 3. Wait long enough for transactions to have been inserted:
waitForTxImmutability ctx
- -- 4/ Recurse, until the server tells us there's nothing left to migrate
+ -- 4. Recurse until the server tells us there's nothing left to
+ -- migrate:
migrateWallet ctx src targets
where
- endpointInfo =
+ endpointCreateMigrationPlan =
Link.createMigrationPlan @'Byron src
- endpointMigration =
+ endpointMigrateWallet =
Link.migrateWallet @'Byron src
endpointListTxs =
Link.listTransactions @'Byron src
endpointForget =
Link.deleteTransaction @'Byron src
- payload = Json
- [json|{"passphrase": #{fixturePassphrase}, "addresses": #{targets}}|]
+ payloadCreateMigrationPlan = Json [json|{"addresses": #{targets}}|]
+ payloadMigrateWallet = Json [json|
+ { "passphrase": #{fixturePassphrase}
+ , "addresses": #{targets}
+ }|]
forgetTxIf predicate tx
| predicate tx =
@@ -535,58 +635,76 @@ spec = describe "BYRON_MIGRATIONS" $ do
| otherwise =
pure ()
- testAddressCycling ctx addrNum =
- forM_ [fixtureRandomWallet, fixtureIcarusWallet]
- $ \fixtureByronWallet -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
+ testAddressCycling sourceWalletType mkSourceWallet targetAddressCount = do
+ let title = mconcat
+ [ "Migration from "
+ , sourceWalletType
+ , " wallet to target address count: "
+ , show targetAddressCount
+ , "."
+ ]
+ it title $ \ctx -> runResourceT $ do
+
-- Restore a Byron wallet with funds, to act as a source wallet:
- sourceWallet <- fixtureByronWallet ctx
- let originalBalance =
- view (#balance . #available . #getQuantity) sourceWallet
+ sourceWallet <- mkSourceWallet ctx
+ let sourceBalance =
+ view (#balance. #available . #getQuantity) sourceWallet
-- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addrIds =
- map (\(ApiTypes.ApiAddress theid _ _) -> theid) $
- take addrNum addrs
-
- -- Calculate the expected migration fee:
- r0 <- request @(ApiWalletMigrationPlan n) ctx
- (Link.createMigrationPlan @'Byron sourceWallet) Default Empty
- verify r0
- [ expectResponseCode HTTP.status200
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = take targetAddressCount targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Create a migration plan:
+ response0 <- request @(ApiWalletMigrationPlan n) ctx
+ (Link.createMigrationPlan @'Byron sourceWallet) Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response0
+ [ expectResponseCode HTTP.status202
, expectField #totalFee (.> Quantity 0)
]
- let expectedFee =
- getFromResponse (#totalFee . #getQuantity) r0
- let balanceLeftover =
- getFromResponse (#balanceLeftover . #ada . #getQuantity) r0
+ let expectedFee = getFromResponse
+ (#totalFee . #getQuantity) response0
+ let balanceLeftover = getFromResponse
+ (#balanceLeftover . #ada . #getQuantity) response0
-- Perform a migration from the source wallet to the target wallet:
- r1 <- request @[ApiTransaction n] ctx
+ response1 <- request @[ApiTransaction n] ctx
(Link.migrateWallet @'Byron sourceWallet)
Default
(Json [json|
{ passphrase: #{fixturePassphrase}
- , addresses: #{addrIds}
+ , addresses: #{targetAddressIds}
}|])
- verify r1
+ verify response1
[ expectResponseCode HTTP.status202
, expectField id (`shouldSatisfy` (not . null))
]
- -- Check that funds become available in the target wallet:
- let expectedBalance =
- originalBalance - expectedFee - balanceLeftover
- eventually "Wallet has expectedBalance" $ do
- r2 <- request @ApiWallet ctx
+ -- Check that funds have become available in the target wallet:
+ let expectedTargetBalance =
+ sourceBalance - expectedFee - balanceLeftover
+ eventually "Target wallet has expected balance." $ do
+ response2 <- request @ApiWallet ctx
(Link.getWallet @'Shelley targetWallet) Default Empty
- verify r2
+ verify response2
[ expectField
- (#balance . #available)
- (`shouldBe` Quantity expectedBalance)
+ (#balance . #available)
+ (`shouldBe` Quantity expectedTargetBalance)
, expectField
- (#balance . #total)
- (`shouldBe` Quantity expectedBalance)
+ (#balance . #total)
+ (`shouldBe` Quantity expectedTargetBalance)
]
+
+ -- Check that the source wallet has a balance of zero:
+ responseFinalSourceBalance <- request @ApiByronWallet ctx
+ (Link.getWallet @'Byron sourceWallet) Default Empty
+ verify responseFinalSourceBalance
+ [ expectField
+ (#balance . #available)
+ (`shouldBe` Quantity 0)
+ , expectField
+ (#balance . #total)
+ (`shouldBe` Quantity 0)
+ ]
diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Migrations.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Migrations.hs
index fabd2b1b8f6..34917b10da8 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Migrations.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Migrations.hs
@@ -17,7 +17,7 @@ module Test.Integration.Scenario.API.Shelley.Migrations
import Prelude
import Cardano.Mnemonic
- ( entropyToMnemonic, genEntropy )
+ ( entropyToMnemonic, genEntropy, mnemonicToText )
import Cardano.Wallet.Api.Types
( ApiT (..)
, ApiTransaction
@@ -39,6 +39,10 @@ import Cardano.Wallet.Primitive.AddressDerivation.Shelley
( ShelleyKey )
import Cardano.Wallet.Primitive.Types.Address
( Address )
+import Cardano.Wallet.Primitive.Types.Coin
+ ( Coin (..) )
+import Cardano.Wallet.Primitive.Types.TokenBundle
+ ( TokenBundle (..) )
import Cardano.Wallet.Primitive.Types.Tx
( TxStatus (..) )
import Control.Monad
@@ -47,6 +51,10 @@ import Control.Monad.IO.Class
( liftIO )
import Control.Monad.Trans.Resource
( runResourceT )
+import Data.Function
+ ( (&) )
+import Data.Functor
+ ( (<&>) )
import Data.Generics.Internal.VL.Lens
( view, (^.) )
import Data.Maybe
@@ -55,16 +63,18 @@ import Data.Proxy
( Proxy )
import Data.Quantity
( Quantity (..) )
-import Data.Text
- ( Text )
import Data.Word
( Word64 )
+import Numeric.Natural
+ ( Natural )
import Test.Hspec
( SpecWith, describe, pendingWith )
import Test.Hspec.Expectations.Lifted
( shouldBe, shouldSatisfy )
import Test.Hspec.Extra
( it )
+import Test.Integration.Faucet
+ ( bigDustWallet, onlyDustWallet )
import Test.Integration.Framework.DSL
( Context (..)
, Headers (..)
@@ -76,6 +86,7 @@ import Test.Integration.Framework.DSL
, expectErrorMessage
, expectField
, expectResponseCode
+ , fixtureMultiAssetWallet
, fixturePassphrase
, fixtureWallet
, getFromResponse
@@ -101,7 +112,10 @@ import Test.Integration.Framework.TestData
import qualified Cardano.Wallet.Api.Link as Link
import qualified Cardano.Wallet.Api.Types as ApiTypes
+import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
+import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
import qualified Network.HTTP.Types.Status as HTTP
import qualified Test.Hspec as Hspec
@@ -114,330 +128,595 @@ spec :: forall n.
, PaymentAddress n ByronKey
) => SpecWith Context
spec = describe "SHELLEY_MIGRATIONS" $ do
- it "SHELLEY_CALCULATE_01 - \
- \for non-empty wallet calculated fee is > zero."
+
+ it "SHELLEY_CREATE_MIGRATION_PLAN_01 - \
+ \Can create a migration plan."
$ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- fixtureWallet ctx
- let ep = Link.createMigrationPlan @'Shelley w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- verify r
- [ expectResponseCode HTTP.status200
+ sourceWallet <- fixtureWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Shelley sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
+ [ expectResponseCode HTTP.status202
, expectField (#totalFee . #getQuantity)
- (.> 0)
+ (`shouldBe` 255_200)
+ , expectField (#selections)
+ ((`shouldBe` 1) . length)
+ , expectField (#balanceSelected . #ada . #getQuantity)
+ (`shouldBe` 1_000_000_000_000)
+ , expectField (#balanceLeftover . #ada . #getQuantity)
+ (`shouldBe` 0)
]
- it "SHELLEY_CALCULATE_02 - \
- \Cannot calculate fee for empty wallet."
+ it "SHELLEY_CREATE_MIGRATION_PLAN_02 - \
+ \Cannot create plan for empty wallet."
$ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- emptyWallet ctx
- let ep = Link.createMigrationPlan @'Shelley w
- r <- request @(ApiWalletMigrationPlan n) ctx ep Default Empty
- verify r
+ sourceWallet <- emptyWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Shelley sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
[ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate $ w ^. walletId)
+ , expectErrorMessage
+ (errMsg403NothingToMigrate $ sourceWallet ^. walletId)
]
- describe "SHELLEY_CALCULATE_03 - \
- \Cannot estimate migration for Byron wallet using Shelley endpoint" $ do
- forM_ [ ("Byron", emptyRandomWallet)
- , ("Icarus", emptyIcarusWallet)
- ] $ \(walType, byronWallet) -> do
-
- it ("Cannot calculate Shelley migration using wallet: " ++ walType)
- $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- w <- byronWallet ctx
- let ep = Link.createMigrationPlan @'Shelley w
- r <- request
- @(ApiWalletMigrationPlan n) ctx ep Default Empty
- expectResponseCode HTTP.status404 r
- expectErrorMessage (errMsg404NoWallet $ w ^. walletId) r
+ describe "SHELLEY_CREATE_MIGRATION_PLAN_03 - \
+ \Cannot create plan for Byron wallet using Shelley endpoint." $ do
+ let sourceWallets =
+ [ ("Random", emptyRandomWallet)
+ , ("Icarus", emptyIcarusWallet)
+ ]
+ forM_ sourceWallets $ \(walletType, byronWallet) -> do
+ let title = mconcat
+ [ "Cannot calculate Shelley migration using wallet: "
+ , walletType
+ ]
+ it title $ \ctx -> runResourceT $ do
+ sourceWallet <- byronWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Shelley sourceWallet
+ result <- request
+ @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify result
+ [ expectResponseCode HTTP.status404
+ , expectErrorMessage
+ (errMsg404NoWallet $ sourceWallet ^. walletId)
+ ]
+
+ it "SHELLEY_CREATE_MIGRATION_PLAN_04 - \
+ \Cannot create a plan for a wallet that only contains dust."
+ $ \ctx -> runResourceT $ do
+ liftIO $ pendingWith
+ "Disabled until a real dust wallet is available."
+ let payloadRestore = Json [json| {
+ "name": "Dust Shelley Wallet",
+ "mnemonic_sentence": #{mnemonicToText onlyDustWallet},
+ "passphrase": #{fixturePassphrase},
+ "style": "random"
+ } |]
+ sourceWallet <- unsafeResponse <$> postWallet ctx payloadRestore
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Shelley sourceWallet
+ response <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage
+ (errMsg403NothingToMigrate $ sourceWallet ^. walletId)
+ ]
+
+ it "SHELLEY_CREATE_MIGRATION_PLAN_05 - \
+ \Creating a plan is deterministic."
+ $ \ctx -> runResourceT $ do
+ sourceWallet <- fixtureWallet ctx
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.createMigrationPlan @'Shelley sourceWallet
+ response1 <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ response2 <- request @(ApiWalletMigrationPlan n) ctx ep Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ expectResponseCode HTTP.status202 response1
+ expectResponseCode HTTP.status202 response2
+ expectField (#selections) ((.> 0) . length) response1
+ expectField (#selections) ((.> 0) . length) response2
+ case (snd response1, snd response2) of
+ (Right plan1, Right plan2) ->
+ plan1 `shouldBe` plan2
+ _ ->
+ error "Unable to compare plans."
describe "SHELLEY_MIGRATE_01 - \
- \after a migration operation successfully completes, the correct \
- \amount eventually becomes available in the target wallet for arbitrary \
- \ number of specified addresses. Balance of source wallet = 0."
+ \After a migration operation successfully completes, the correct \
+ \amounts eventually become available in the target wallet for an \
+ \arbitrary number of specified addresses, and the balance of the \
+ \source wallet is completely depleted."
$ do
- testAddressCycling 1
- testAddressCycling 3
- testAddressCycling 10
+ testAddressCycling 1
+ testAddressCycling 3
+ testAddressCycling 10
- Hspec.it "SHELLEY_MIGRATE_01_big_wallet - \
- \ migrate a big wallet requiring more than one tx" $ \ctx -> runResourceT @IO $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
+ Hspec.it "SHELLEY_MIGRATE_02 - \
+ \Can migrate a large wallet requiring more than one transaction."
+ $ \ctx -> runResourceT @IO $ do
- -- NOTE
- -- Special mnemonic for which 200 shelley funds are attached to in the
- -- genesis file.
- --
- -- Out of these 200 coins, 100 of them are of 1 ADA and are
- -- expected to be treated as dust. The rest are all worth:
- -- 10,000,000,000 lovelace.
- let mnemonics =
- ["radar", "scare", "sense", "winner", "little"
- , "jeans", "blue", "spell", "mystery", "sketch"
- , "omit", "time", "tiger", "leave", "load"] :: [Text]
- let payloadRestore = Json [json| {
+ -- Create a large source wallet from which funds will be migrated:
+ sourceWallet <- unsafeResponse <$> postWallet ctx
+ (Json [json|{
"name": "Big Shelley Wallet",
- "mnemonic_sentence": #{mnemonics},
+ "mnemonic_sentence": #{mnemonicToText bigDustWallet},
"passphrase": #{fixturePassphrase}
- } |]
- wOld <- unsafeResponse <$> postWallet ctx payloadRestore
- originalBalance <- eventually "wallet balance greater than 0" $ do
- r <- request @ApiWallet ctx
- (Link.getWallet @'Shelley wOld)
- Default
- Empty
- verify r
- [ expectField (#balance . #available) (.> Quantity 0)
+ }|])
+ sourceBalance <- eventually "Source wallet balance is correct." $ do
+ response <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley sourceWallet) Default Empty
+ verify response
+ [ expectField (#balance . #available . #getQuantity)
+ (`shouldBe` 10_000_100_000_000)
]
return $ getFromResponse
- (#balance . #available . #getQuantity) r
-
- -- Calculate the expected migration fee:
- rFee <- request @(ApiWalletMigrationPlan n) ctx
- (Link.createMigrationPlan @'Shelley wOld)
- Default
- Empty
- verify rFee
- [ expectResponseCode HTTP.status200
- , expectField #totalFee (.> Quantity 0)
+ (#balance . #available . #getQuantity) response
+
+ -- Create an empty target wallet:
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Compute the expected migration plan:
+ responsePlan <- request @(ApiWalletMigrationPlan n) ctx
+ (Link.createMigrationPlan @'Shelley sourceWallet) Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify responsePlan
+ [ expectResponseCode HTTP.status202
+ , expectField
+ (#totalFee . #getQuantity)
+ (`shouldBe` 3_120_400)
+ , expectField
+ (#selections)
+ ((`shouldBe` 2) . length)
+ , expectField
+ (#balanceLeftover . #ada . #getQuantity)
+ (`shouldBe` 0)
+ , expectField
+ (#balanceSelected . #ada . #getQuantity)
+ (`shouldBe` 10_000_100_000_000)
]
- let expectedFee =
- getFromResponse (#totalFee . #getQuantity) rFee
- let balanceLeftover =
- getFromResponse (#balanceLeftover . #ada . #getQuantity) rFee
-
- -- Migrate to a new empty wallet
- wNew <- emptyWallet ctx
- addrs <- listAddresses @n ctx wNew
- let addr1 = (addrs !! 1) ^. #id
-
-
- -- NOTE
- -- The migration typically involves many transactions being sent one by
- -- one. It may happen that one of these transaction is rolled back and
- -- simply discarded entirely from mem pools. There's no retry mechanism
- -- from the wallet _yet_, which means that such transactions must be
- -- manually retried by clients.
+ let expectedFee = getFromResponse
+ (#totalFee . #getQuantity) responsePlan
+ let balanceLeftover = getFromResponse
+ (#balanceLeftover . #ada . #getQuantity) responsePlan
+
+ -- Perform a migration from the source wallet to the target wallet.
--
- -- This 'migrateWallet' function does exactly this, and will try to make
- -- sure that rolledback functions are canceled and retried up until the
- -- full migration is done.
- liftIO $ migrateWallet ctx wOld [addr1]
-
- -- Check that funds become available in the target wallet: Because
- -- there's a bit of non-determinism in how the migration is really done,
- -- we can expect the final balance with exactitude. Yet, we still expect
- -- it to be not too far away from an ideal value.
- let expectedMinBalance =
- originalBalance - 2 * expectedFee - balanceLeftover
- eventually "wallet balance ~ expectedBalance" $ do
- request @ApiWallet ctx
- (Link.getWallet @'Shelley wNew)
- Default
- Empty >>= flip verify
+ -- This migration will involve more than one transaction, where each
+ -- transaction is sent one by one. It may happen that one of these
+ -- transactions is rolled back or simply discarded entirely. The wallet
+ -- doesn't currently have any retry mechanism, which means that
+ -- transactions must be manually retried by clients.
+ --
+ -- The 'migrateWallet' function tries do exactly that: to make sure
+ -- that rolled-back transactions are cancelled and retried until the
+ -- migration is complete.
+ --
+ liftIO $ migrateWallet ctx sourceWallet targetAddressIds
+
+ -- Check that funds become available in the target wallet:
+ let expectedTargetBalance =
+ sourceBalance - balanceLeftover - expectedFee
+ eventually "Target wallet balance reaches expected balance" $ do
+ response <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley targetWallet) Default Empty
+ verify response
[ expectField
- (#balance . #available)
- (.> (Quantity expectedMinBalance))
+ (#balance . #available . #getQuantity)
+ (`shouldBe` expectedTargetBalance)
, expectField
- (#balance . #total)
- (.> (Quantity expectedMinBalance))
+ (#balance . #total . #getQuantity)
+ (`shouldBe` expectedTargetBalance)
]
- -- Analyze the target wallet UTxO distribution
- request @ApiUtxoStatistics ctx (Link.getUTxOsStatistics @'Shelley wNew)
- Default
- Empty >>= flip verify
+ -- Analyse the target wallet's UTxO distribution:
+ responseStats <- request @ApiUtxoStatistics ctx
+ (Link.getUTxOsStatistics @'Shelley targetWallet) Default Empty
+ verify responseStats
[ expectField
- #distribution
- ((`shouldBe` (Just 100)) . Map.lookup 100_000_000_000)
+ (#distribution)
+ ((`shouldBe` (Just 2)) . Map.lookup 10_000_000_000_000)
+ ]
+
+ -- Check that the source wallet has the expected leftover balance:
+ responseFinalSourceBalance <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley sourceWallet) Default Empty
+ verify responseFinalSourceBalance
+ [ expectResponseCode HTTP.status200
+ , expectField (#balance . #available)
+ (`shouldBe` Quantity 0)
+ , expectField (#balance . #total)
+ (`shouldBe` Quantity 0)
]
- it "SHELLEY_MIGRATE_02 - \
- \migrating an empty wallet should fail."
+ it "SHELLEY_MIGRATE_03 - \
+ \Migrating an empty wallet should fail."
$ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
sourceWallet <- emptyWallet ctx
+ let sourceWalletId = sourceWallet ^. walletId
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+ let ep = Link.migrateWallet @'Shelley sourceWallet
+ response <- request @[ApiTransaction n] ctx ep Default $
Json [json|
{ passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
+ , addresses: #{targetAddressIds}
}|]
- let ep = Link.migrateWallet @'Shelley sourceWallet
- r <- request @[ApiTransaction n] ctx ep Default payload
- let srcId = sourceWallet ^. walletId
- verify r
+ verify response
[ expectResponseCode HTTP.status403
- , expectErrorMessage (errMsg403NothingToMigrate srcId)
+ , expectErrorMessage (errMsg403NothingToMigrate sourceWalletId)
]
- Hspec.it "SHELLEY_MIGRATE_02 - \
- \migrating wallet with 'dust' (that complies with minUTxOValue) should pass."
+ Hspec.it "SHELLEY_MIGRATE_04 - \
+ \Actual fee for migration is identical to predicted fee."
$ \ctx -> runResourceT @IO $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- NOTE
- -- Special mnemonic for which wallet has dust
- -- (10 utxo with 43 ADA)
- let mnemonics =
- ["either", "flip", "maple", "shift", "dismiss", "bridge"
- , "sweet", "reveal", "green", "tornado", "need", "patient"
- , "wall", "stamp", "pass"] :: [Text]
- let payloadRestore = Json [json| {
- "name": "Dust Shelley Wallet",
- "mnemonic_sentence": #{mnemonics},
+
+ let feeExpected = 255_200
+
+ -- Restore a source wallet with funds:
+ sourceWallet <- fixtureWallet ctx
+
+ -- Create an empty target wallet:
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Create a migration plan:
+ let endpointPlan = (Link.createMigrationPlan @'Shelley sourceWallet)
+ responsePlan <- request @(ApiWalletMigrationPlan n)
+ ctx endpointPlan Default $
+ Json [json|{addresses: #{targetAddressIds}}|]
+ -- Verify the fee is as expected:
+ verify responsePlan
+ [ expectResponseCode HTTP.status202
+ , expectField #totalFee (`shouldBe` Quantity feeExpected)
+ , expectField #selections ((`shouldBe` 1) . length)
+ ]
+
+ -- Perform a migration:
+ let endpointMigrate = Link.migrateWallet @'Shelley sourceWallet
+ responseMigrate <-
+ request @[ApiTransaction n] ctx endpointMigrate Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
+ -- Verify the fee is as expected:
+ verify responseMigrate
+ [ expectResponseCode HTTP.status202
+ , expectField id ((`shouldBe` 1) . length)
+ , expectField id
+ $ (`shouldBe` feeExpected)
+ . fromIntegral
+ . sum
+ . fmap apiTransactionFee
+ ]
+
+ it "SHELLEY_MIGRATE_05 - \
+ \Migration fails if the wrong passphrase is supplied."
+ $ \ctx -> runResourceT $ do
+
+ -- Restore a Shelley wallet with funds, to act as a source wallet:
+ sourceWallet <- fixtureWallet ctx
+
+ -- Create an empty target wallet:
+ targetWallet <- emptyWallet ctx
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Attempt to perform a migration:
+ response <- request @[ApiTransaction n] ctx
+ (Link.migrateWallet @'Shelley sourceWallet)
+ Default
+ (Json [json|
+ { passphrase: "not-the-right-passphrase"
+ , addresses: #{targetAddressIds}
+ }|])
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage errMsg403WrongPass
+ ]
+
+ it "SHELLEY_MIGRATE_06 - \
+ \It's possible to migrate to any valid address."
+ $ \ctx -> runResourceT $ do
+
+ -- Create a Shelley address:
+ wShelley <- emptyWallet ctx
+ addrs <- listAddresses @n ctx wShelley
+ let addrShelley = (addrs !! 1) ^. #id
+
+ -- Create an Icarus address:
+ addrIcarus <- liftIO $ encodeAddress @n . head . icarusAddresses @n
+ . entropyToMnemonic @15 <$> genEntropy
+
+ -- Create a Byron address:
+ addrByron <- liftIO $ encodeAddress @n . head . randomAddresses @n
+ . entropyToMnemonic @12 <$> genEntropy
+
+ -- Create a source wallet:
+ sourceWallet <- emptyWallet ctx
+
+ -- Initiate a migration to all address types:
+ response <- request @[ApiTransaction n] ctx
+ (Link.migrateWallet @'Shelley sourceWallet) Default
+ (Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: [#{addrShelley}, #{addrIcarus}, #{addrByron}]
+ }|])
+ verify response
+ [ expectResponseCode HTTP.status403
+ , expectErrorMessage
+ (errMsg403NothingToMigrate (sourceWallet ^. walletId))
+ ]
+
+ it "SHELLEY_MIGRATE_07 - \
+ \Including an invalidly-formatted passphrase results in a parser error."
+ $ \ctx -> runResourceT $ do
+ sourceWallet <- emptyWallet ctx
+ response <- request @[ApiTransaction n] ctx
+ (Link.migrateWallet @'Shelley sourceWallet) Default
+ (NonJson "{passphrase:,}")
+ verify response
+ [ expectResponseCode HTTP.status400
+ , expectErrorMessage errMsg400ParseError
+ ]
+
+ Hspec.it "SHELLEY_MIGRATE_08 - \
+ \It's possible to migrate a wallet with many small ada quantities, \
+ \provided that the total balance is significantly greater than the \
+ \minimum ada quantity for an output."
+ $ \ctx -> runResourceT @IO $ do
+
+ -- Create a source wallet with many small ada quantities:
+ sourceWallet <- unsafeResponse <$> postWallet ctx
+ (Json [json|{
+ "name": "Shelley Wallet",
+ "mnemonic_sentence": #{mnemonicToText onlyDustWallet},
"passphrase": #{fixturePassphrase}
- } |]
- sourceWallet <- unsafeResponse <$> postWallet ctx payloadRestore
- originalBalance <- eventually "wallet balance greater than 0" $ do
- rg <- request @ApiWallet ctx
- (Link.getWallet @'Shelley sourceWallet)
- Default
- Empty
- verify rg
- [ expectField (#balance . #available) (.> Quantity 0)
+ }|])
+ sourceBalance <- eventually "Source wallet balance is correct." $ do
+ response <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley sourceWallet) Default Empty
+ verify response
+ [ expectField (#balance . #available . #getQuantity)
+ (`shouldBe` 43_000_000)
+ , expectField (#balance . #total . #getQuantity)
+ (`shouldBe` 43_000_000)
]
pure $ getFromResponse (#balance. #available . #getQuantity)
- rg
+ response
- -- Calculate the expected migration fee:
- r0 <- request @(ApiWalletMigrationPlan n) ctx
- (Link.createMigrationPlan @'Shelley sourceWallet) Default Empty
- verify r0
- [ expectResponseCode HTTP.status200
- , expectField #totalFee (.> Quantity 0)
+ -- Analyse the source wallet's UTxO distribution:
+ let expectedSourceDistribution =
+ [ ( 1_000_000, 3)
+ , ( 10_000_000, 6)
+ , (100_000_000, 1)
+ ]
+ responseSourceDistribution <- request @ApiUtxoStatistics ctx
+ (Link.getUTxOsStatistics @'Shelley sourceWallet) Default Empty
+ verify responseSourceDistribution
+ [ expectField #distribution
+ ((`shouldBe` expectedSourceDistribution)
+ . Map.toList
+ . Map.filter (> 0)
+ )
]
- let expectedFee = getFromResponse (#totalFee . #getQuantity) r0
+ -- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
- Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
- }|]
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Compute the expected migration plan:
+ let feeExpected = 254_800
+ responsePlan <- request @(ApiWalletMigrationPlan n) ctx
+ (Link.createMigrationPlan @'Shelley sourceWallet) Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify responsePlan
+ [ expectResponseCode HTTP.status202
+ , expectField #totalFee (`shouldBe` Quantity feeExpected)
+ , expectField #selections ((`shouldBe` 1) . length)
+ ]
+
+ -- Perform the migration:
let ep = Link.migrateWallet @'Shelley sourceWallet
- r <- request @[ApiTransaction n] ctx ep Default payload
- verify r
- [ expectResponseCode HTTP.status202 ]
+ responseMigrate <- request @[ApiTransaction n] ctx ep Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
+
+ -- Verify the fee is as expected:
+ verify responseMigrate
+ [ expectResponseCode HTTP.status202
+ , expectField id ((`shouldBe` 1) . length)
+ , expectField id
+ $ (`shouldBe` feeExpected)
+ . fromIntegral
+ . sum
+ . fmap apiTransactionFee
+ ]
-- Check that funds become available in the target wallet:
- let expectedBalance = originalBalance - expectedFee
- eventually "targetWallet balance = expectedBalance" $ do
+ let expectedBalance = sourceBalance - feeExpected
+ eventually "Target wallet balance reaches the expected amount." $ do
request @ApiWallet ctx
(Link.getWallet @'Shelley targetWallet)
Default
Empty >>= flip verify
[ expectField
- (#balance . #available)
- ( `shouldBe` Quantity expectedBalance)
+ (#balance . #available)
+ ( `shouldBe` Quantity expectedBalance)
, expectField
- (#balance . #total)
- ( `shouldBe` Quantity expectedBalance)
+ (#balance . #total)
+ ( `shouldBe` Quantity expectedBalance)
]
- it "SHELLEY_MIGRATE_03 - \
- \actual fee for migration is the same as the predicted fee."
- $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- Restore a Shelley wallet with funds.
- sourceWallet <- fixtureWallet ctx
-
- -- Request a migration fee prediction.
- let ep0 = (Link.createMigrationPlan @'Shelley sourceWallet)
- r0 <- request @(ApiWalletMigrationPlan n) ctx ep0 Default Empty
- verify r0
- [ expectResponseCode HTTP.status200
- , expectField #totalFee (.> Quantity 0)
+ -- Analyse the target wallet's UTxO distribution:
+ let expectedTargetDistribution = [(100_000_000, 1)]
+ responseTargetDistribution <- request @ApiUtxoStatistics ctx
+ (Link.getUTxOsStatistics @'Shelley targetWallet) Default Empty
+ verify responseTargetDistribution
+ [ expectField #distribution
+ ((`shouldBe` expectedTargetDistribution)
+ . Map.toList
+ . Map.filter (> 0)
+ )
]
- -- Perform the migration.
+ Hspec.it "SHELLEY_MIGRATE_MULTI_ASSET_01 - \
+ \Can migrate a multi-asset wallet."
+ $ \ctx -> runResourceT @IO $ do
+
+ -- Restore a source wallet with funds:
+ sourceWallet <- fixtureMultiAssetWallet ctx
+
+ -- Wait for the source wallet balance to be correct:
+ let expectedAdaBalance = 40_000_000
+ sourceBalance <- eventually "Source wallet balance is correct." $ do
+ response <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley sourceWallet) Default Empty
+ verify response
+ [ expectField (#balance . #available . #getQuantity)
+ (`shouldBe` expectedAdaBalance)
+ , expectField (#balance . #total . #getQuantity)
+ (`shouldBe` expectedAdaBalance)
+ , expectField (#assets . #available . #getApiT)
+ ((`shouldBe` 8) . Set.size . TokenMap.getAssets)
+ , expectField (#assets . #total . #getApiT)
+ ((`shouldBe` 8) . Set.size . TokenMap.getAssets)
+ ]
+ let balanceAda = response
+ & getFromResponse (#balance . #available . #getQuantity)
+ & fromIntegral
+ & Coin
+ let balanceAssets = response
+ & getFromResponse (#assets . #available . #getApiT)
+ pure $ TokenBundle balanceAda balanceAssets
+
+ -- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- let payload =
- Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addr1}]
- }|]
- let ep1 = Link.migrateWallet @'Shelley sourceWallet
- r1 <- request @[ApiTransaction n] ctx ep1 Default payload
- verify r1
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Create a migration plan:
+ let endpointPlan = (Link.createMigrationPlan @'Shelley sourceWallet)
+ responsePlan <- request @(ApiWalletMigrationPlan n)
+ ctx endpointPlan Default $
+ Json [json|{addresses: #{targetAddressIds}}|]
+
+ -- Verify the plan is as expected:
+ let expectedFee = 191_100
+ verify responsePlan
[ expectResponseCode HTTP.status202
- , expectField id (`shouldSatisfy` (not . null))
+ , expectField (#totalFee . #getQuantity)
+ (`shouldBe` expectedFee)
+ , expectField (#selections)
+ ((`shouldBe` 1) . length)
+ , expectField id
+ ((`shouldBe` 3) . apiPlanTotalInputCount)
+ , expectField id
+ ((`shouldBe` 1) . apiPlanTotalOutputCount)
+ , expectField (#balanceSelected . #ada)
+ (`shouldBe` coinToQuantity (view #coin sourceBalance))
+ , expectField (#balanceLeftover . #ada . #getQuantity)
+ (`shouldBe` 0)
+ , expectField (#balanceSelected . #assets . #getApiT)
+ (`shouldBe` view #tokens sourceBalance)
+ , expectField (#balanceLeftover . #assets . #getApiT)
+ (`shouldSatisfy` TokenMap.isEmpty)
]
- -- Verify that the fee prediction was correct.
- let actualFee = fromIntegral $ sum $ apiTransactionFee
- <$> getFromResponse id r1
- let predictedFee =
- getFromResponse (#totalFee . #getQuantity) r0
- liftIO $ actualFee `shouldBe` predictedFee
-
- it "SHELLEY_MIGRATE_04 - migration fails with a wrong passphrase" $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- -- Restore a Shelley wallet with funds, to act as a source wallet:
- sourceWallet <- fixtureWallet ctx
+ -- Perform a migration:
+ let endpointMigrate = Link.migrateWallet @'Shelley sourceWallet
+ responseMigrate <-
+ request @[ApiTransaction n] ctx endpointMigrate Default $
+ Json [json|
+ { passphrase: #{fixturePassphrase}
+ , addresses: #{targetAddressIds}
+ }|]
- -- Perform a migration from the source wallet to a target wallet:
- targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addr1 = (addrs !! 1) ^. #id
- r0 <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Shelley sourceWallet)
- Default
- (Json [json|
- { passphrase: "not-the-right-passphrase"
- , addresses: [#{addr1}]
- }|])
- verify r0
- [ expectResponseCode HTTP.status403
- , expectErrorMessage errMsg403WrongPass
- ]
+ -- Verify the fee is as expected:
+ verify responseMigrate
+ [ expectResponseCode HTTP.status202
+ , expectField id ((`shouldBe` 1) . length)
+ , expectField id
+ $ (`shouldBe` expectedFee)
+ . fromIntegral
+ . sum
+ . fmap apiTransactionFee
+ ]
+ -- Check that funds become available in the target wallet:
+ let expectedTargetBalance = expectedAdaBalance - expectedFee
+ eventually "Target wallet balance reaches the expected amount." $ do
+ request @ApiWallet ctx
+ (Link.getWallet @'Shelley targetWallet) Default Empty
+ >>= flip verify
+ [ expectField
+ (#balance . #available)
+ (`shouldBe` Quantity expectedTargetBalance)
+ , expectField
+ (#balance . #total)
+ (`shouldBe` Quantity expectedTargetBalance)
+ , expectField
+ (#assets . #available . #getApiT)
+ (`shouldBe` view #tokens sourceBalance)
+ , expectField
+ (#assets . #total . #getApiT)
+ (`shouldBe` view #tokens sourceBalance)
+ ]
- it "SHELLEY_MIGRATE_05 - I could migrate to any valid address" $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- --shelley address
- wShelley <- emptyWallet ctx
- addrs <- listAddresses @n ctx wShelley
- let addrShelley = (addrs !! 1) ^. #id
- --icarus address
- addrIcarus <- liftIO $ encodeAddress @n . head . icarusAddresses @n
- . entropyToMnemonic @15 <$> genEntropy
- --byron address
- addrByron <- liftIO $ encodeAddress @n . head . randomAddresses @n
- . entropyToMnemonic @12 <$> genEntropy
-
- sWallet <- emptyWallet ctx
- r <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Shelley sWallet)
- Default
- (Json [json|
- { passphrase: #{fixturePassphrase}
- , addresses: [#{addrShelley}, #{addrIcarus}, #{addrByron}]
- }|])
- verify r
- [ expectResponseCode HTTP.status403
- , expectErrorMessage
- (errMsg403NothingToMigrate (sWallet ^. walletId))
- ]
-
- it "SHELLEY_MIGRATE_07 - invalid payload, parser error" $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
- sourceWallet <- emptyWallet ctx
- r <- request @[ApiTransaction n] ctx
- (Link.migrateWallet @'Shelley sourceWallet)
- Default
- (NonJson "{passphrase:,}")
- expectResponseCode HTTP.status400 r
- expectErrorMessage errMsg400ParseError r
+ -- Check that the source wallet has been depleted:
+ responseFinalSourceBalance <- request @ApiWallet ctx
+ (Link.getWallet @'Shelley sourceWallet) Default Empty
+ verify responseFinalSourceBalance
+ [ expectResponseCode HTTP.status200
+ , expectField
+ (#balance . #available)
+ (`shouldBe` Quantity 0)
+ , expectField
+ (#balance . #total)
+ (`shouldBe` Quantity 0)
+ , expectField
+ (#assets . #available . #getApiT)
+ (`shouldSatisfy` TokenMap.isEmpty)
+ , expectField
+ (#assets . #total . #getApiT)
+ (`shouldSatisfy` TokenMap.isEmpty)
+ ]
where
-- Compute the fee associated with an API transaction.
apiTransactionFee :: ApiTransaction n -> Word64
@@ -460,33 +739,41 @@ spec = describe "SHELLEY_MIGRATIONS" $ do
-> [(ApiT Address, Proxy n)]
-> IO ()
migrateWallet ctx src targets = do
- (st, _) <- request
- @(ApiWalletMigrationPlan n) ctx endpointInfo Default Empty
- when (st == HTTP.status200) $ do -- returns '403 Nothing to Migrate' when done
- -- 1/ Forget all pending transactions to unlock any locked UTxO
- (_, txs) <- unsafeRequest @[ApiTransaction n] ctx endpointListTxs Empty
+ (status, _) <- request @(ApiWalletMigrationPlan n) ctx
+ endpointCreateMigrationPlan Default payloadCreateMigrationPlan
+ when (status == HTTP.status202) $ do
+ -- The above request returns '403 Nothing to Migrate' when done.
+
+ -- 1. Forget all pending transactions to unlock any locked UTxO:
+ (_, txs) <- unsafeRequest
+ @[ApiTransaction n] ctx endpointListTxs Empty
forM_ txs $ forgetTxIf ((== ApiT Pending) . view #status)
- -- 2/ Attempt to migrate
- _ <- request @[ApiTransaction n] ctx endpointMigration Default payload
+ -- 2. Attempt to migrate:
+ _ <- request @[ApiTransaction n] ctx endpointMigrateWallet Default
+ payloadMigrateWallet
- -- 3/ Wait "long-enough" for transactions to have been inserted.
+ -- 3. Wait long enough for transactions to have been inserted:
waitForTxImmutability ctx
- -- 4/ Recurse, until the server tells us there's nothing left to migrate
+ -- 4. Recurse until the server tells us there's nothing left to
+ -- migrate:
migrateWallet ctx src targets
where
- endpointInfo =
+ endpointCreateMigrationPlan =
Link.createMigrationPlan @'Shelley src
- endpointMigration =
+ endpointMigrateWallet =
Link.migrateWallet @'Shelley src
endpointListTxs =
Link.listTransactions @'Shelley src
endpointForget =
Link.deleteTransaction @'Shelley src
- payload = Json
- [json|{"passphrase": #{fixturePassphrase}, "addresses": #{targets}}|]
+ payloadCreateMigrationPlan = Json [json|{"addresses": #{targets}}|]
+ payloadMigrateWallet = Json [json|
+ { "passphrase": #{fixturePassphrase}
+ , "addresses": #{targets}
+ }|]
forgetTxIf predicate tx
| predicate tx =
@@ -494,67 +781,86 @@ spec = describe "SHELLEY_MIGRATIONS" $ do
| otherwise =
pure ()
- testAddressCycling addrNum =
- it ("Migration from Shelley wallet to " ++ show addrNum ++ " addresses")
- $ \ctx -> runResourceT $ do
- liftIO $ pendingWith "Migration endpoints temporarily disabled."
+ testAddressCycling targetAddressCount = do
+ let title = mconcat
+ [ "Migration from Shelley wallet to target address count: "
+ , show targetAddressCount
+ , "."
+ ]
+ it title $ \ctx -> runResourceT $ do
+
-- Restore a Shelley wallet with funds, to act as a source wallet:
sourceWallet <- fixtureWallet ctx
- let originalBalance =
- view (#balance. #available . #getQuantity)
- sourceWallet
+ let sourceBalance =
+ view (#balance. #available . #getQuantity) sourceWallet
-- Create an empty target wallet:
targetWallet <- emptyWallet ctx
- addrs <- listAddresses @n ctx targetWallet
- let addrIds =
- map (\(ApiTypes.ApiAddress theid _ _) -> theid) $
- take addrNum addrs
-
- -- Calculate the expected migration fee:
- r0 <- request @(ApiWalletMigrationPlan n) ctx
- (Link.createMigrationPlan @'Shelley sourceWallet) Default Empty
- verify r0
- [ expectResponseCode HTTP.status200
+ targetAddresses <- listAddresses @n ctx targetWallet
+ let targetAddressIds = take targetAddressCount targetAddresses <&>
+ (\(ApiTypes.ApiAddress addrId _ _) -> addrId)
+
+ -- Create a migration plan:
+ response0 <- request @(ApiWalletMigrationPlan n) ctx
+ (Link.createMigrationPlan @'Shelley sourceWallet) Default
+ (Json [json|{addresses: #{targetAddressIds}}|])
+ verify response0
+ [ expectResponseCode HTTP.status202
, expectField #totalFee (.> Quantity 0)
]
- let expectedFee = getFromResponse (#totalFee . #getQuantity) r0
+ let expectedFee =
+ getFromResponse (#totalFee . #getQuantity) response0
-- Perform a migration from the source wallet to the target wallet:
- r1 <- request @[ApiTransaction n] ctx
+ response1 <- request @[ApiTransaction n] ctx
(Link.migrateWallet @'Shelley sourceWallet)
Default
(Json [json|
{ passphrase: #{fixturePassphrase}
- , addresses: #{addrIds}
+ , addresses: #{targetAddressIds}
}|])
- verify r1
+ verify response1
[ expectResponseCode HTTP.status202
, expectField id (`shouldSatisfy` (not . null))
]
- -- Check that funds become available in the target wallet:
- let expectedBalance = originalBalance - expectedFee
- eventually "Wallet has expectedBalance" $ do
- r2 <- request @ApiWallet ctx
+ -- Check that funds have become available in the target wallet:
+ let expectedTargetBalance = sourceBalance - expectedFee
+ eventually "Target wallet has expected balance." $ do
+ response2 <- request @ApiWallet ctx
(Link.getWallet @'Shelley targetWallet) Default Empty
- verify r2
+ verify response2
[ expectField
- (#balance . #available)
- (`shouldBe` Quantity expectedBalance)
+ (#balance . #available)
+ (`shouldBe` Quantity expectedTargetBalance)
, expectField
- (#balance . #total)
- (`shouldBe` Quantity expectedBalance)
+ (#balance . #total)
+ (`shouldBe` Quantity expectedTargetBalance)
]
- -- Verify sourceWallet has balance 0
- r3 <- request @ApiWallet ctx
+ -- Check that the source wallet has a balance of zero:
+ responseFinalSourceBalance <- request @ApiWallet ctx
(Link.getWallet @'Shelley sourceWallet) Default Empty
- verify r3
+ verify responseFinalSourceBalance
[ expectField
- (#balance . #available)
- (`shouldBe` Quantity 0)
+ (#balance . #available)
+ (`shouldBe` Quantity 0)
, expectField
- (#balance . #total)
- (`shouldBe` Quantity 0)
+ (#balance . #total)
+ (`shouldBe` Quantity 0)
]
+
+--------------------------------------------------------------------------------
+-- Utility functions
+--------------------------------------------------------------------------------
+
+apiPlanTotalInputCount :: ApiWalletMigrationPlan n -> Int
+apiPlanTotalInputCount p =
+ F.sum (length . view #inputs <$> view #selections p)
+
+apiPlanTotalOutputCount :: ApiWalletMigrationPlan n -> Int
+apiPlanTotalOutputCount p =
+ F.sum (length . view #outputs <$> view #selections p)
+
+coinToQuantity :: Coin -> Quantity "lovelace" Natural
+coinToQuantity = Quantity . fromIntegral . unCoin
diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 130d91857ce..8dd4aaced4e 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -110,6 +110,7 @@ module Cardano.Wallet
, readWalletUTxOIndex
, selectAssetsNoOutputs
, assignChangeAddresses
+ , assignChangeAddressesAndUpdateDb
, selectionToUnsignedTx
, signTransaction
, ErrSelectAssets(..)
@@ -118,6 +119,9 @@ module Cardano.Wallet
, ErrWithdrawalNotWorth (..)
-- ** Migration
+ , createMigrationPlan
+ , migrationPlanToSelectionWithdrawals
+ , ErrCreateMigrationPlan (..)
-- ** Delegation
, PoolRetirementEpochInfo (..)
@@ -276,6 +280,8 @@ import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
, emptySkeleton
, performSelection
)
+import Cardano.Wallet.Primitive.Migration
+ ( MigrationPlan (..) )
import Cardano.Wallet.Primitive.Model
( Wallet
, applyBlocks
@@ -439,6 +445,8 @@ import Data.Time.Clock
( NominalDiffTime, UTCTime )
import Data.Type.Equality
( (:~:) (..), testEquality )
+import Data.Void
+ ( Void )
import Data.Word
( Word64 )
import Fmt
@@ -459,6 +467,7 @@ import UnliftIO.MVar
import qualified Cardano.Crypto.Wallet as CC
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
+import qualified Cardano.Wallet.Primitive.Migration as Migration
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
@@ -1192,7 +1201,7 @@ normalizeDelegationAddress s addr = do
-- to change outputs to which new addresses have been assigned. This updates
-- the wallet state as it needs to keep track of new pending change addresses.
assignChangeAddresses
- :: forall s. (GenChange s)
+ :: forall s. GenChange s
=> ArgGenChange s
-> SelectionResult TokenBundle
-> s
@@ -1203,6 +1212,28 @@ assignChangeAddresses argGenChange sel = runState $ do
pure $ TxOut addr bundle
pure $ sel { changeGenerated = changeOuts }
+assignChangeAddressesAndUpdateDb
+ :: forall ctx s k.
+ ( GenChange s
+ , HasDBLayer IO s k ctx
+ )
+ => ctx
+ -> WalletId
+ -> ArgGenChange s
+ -> SelectionResult TokenBundle
+ -> ExceptT ErrSignPayment IO (SelectionResult TxOut)
+assignChangeAddressesAndUpdateDb ctx wid generateChange selection =
+ db & \DBLayer{..} -> mapExceptT atomically $ do
+ cp <- withExceptT ErrSignPaymentNoSuchWallet $
+ withNoSuchWallet wid $ readCheckpoint wid
+ let (selectionUpdated, stateUpdated) =
+ assignChangeAddresses generateChange selection (getState cp)
+ withExceptT ErrSignPaymentNoSuchWallet $
+ putCheckpoint wid (updateState stateUpdated cp)
+ pure selectionUpdated
+ where
+ db = ctx ^. dbLayer @IO @s @k
+
selectionToUnsignedTx
:: forall s input output change withdrawal.
( IsOurs s Address
@@ -1432,46 +1463,45 @@ selectAssets ctx (utxo, cp, pending) tx outs transform = do
hasWithdrawal :: Tx -> Bool
hasWithdrawal = not . null . withdrawals
--- | Produce witnesses and construct a transaction from a given
--- selection. Requires the encryption passphrase in order to decrypt
--- the root private key. Note that this doesn't broadcast the
--- transaction to the network. In order to do so, use 'submitTx'.
+-- | Produce witnesses and construct a transaction from a given selection.
+--
+-- Requires the encryption passphrase in order to decrypt the root private key.
+-- Note that this doesn't broadcast the transaction to the network. In order to
+-- do so, use 'submitTx'.
+--
signTransaction
:: forall ctx s k.
( HasTransactionLayer k ctx
, HasDBLayer IO s k ctx
, HasNetworkLayer IO ctx
, IsOwned s k
- , GenChange s
)
=> ctx
-> WalletId
- -> ArgGenChange s
- -> ((k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption"))
+ -> ( (k 'RootK XPrv, Passphrase "encryption") ->
+ ( XPrv, Passphrase "encryption")
+ )
-- ^ Reward account derived from the root key (or somewhere else).
-> Passphrase "raw"
-> TransactionCtx
- -> SelectionResult TokenBundle
+ -> SelectionResult TxOut
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
-signTransaction ctx wid argChange mkRwdAcct pwd txCtx sel = db & \DBLayer{..} -> do
+signTransaction ctx wid mkRwdAcct pwd txCtx sel =
+ db & \DBLayer{..} -> do
era <- liftIO $ currentNodeEra nl
withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
let pwdP = preparePassphrase scheme pwd
mapExceptT atomically $ do
- cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
- readCheckpoint wid
+ cp <- withExceptT ErrSignPaymentNoSuchWallet
+ $ withNoSuchWallet wid
+ $ readCheckpoint wid
pp <- liftIO $ currentProtocolParameters nl
- let (sel', s') = assignChangeAddresses argChange sel (getState cp)
- withExceptT ErrSignPaymentNoSuchWallet $
- putCheckpoint wid (updateState s' cp)
-
let keyFrom = isOwned (getState cp) (xprv, pwdP)
let rewardAcnt = mkRwdAcct (xprv, pwdP)
-
(tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
- mkTransaction tl era rewardAcnt keyFrom pp txCtx sel'
-
- (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' txCtx sel'
+ mkTransaction tl era rewardAcnt keyFrom pp txCtx sel
+ (time, meta) <- liftIO $
+ mkTxMeta ti (currentTip cp) (getState cp) txCtx sel
return (tx, meta, time, sealedTx)
where
db = ctx ^. dbLayer @IO @s @k
@@ -1785,6 +1815,80 @@ getTransaction ctx wid tid = db & \DBLayer{..} -> do
where
db = ctx ^. dbLayer @IO @s @k
+{-------------------------------------------------------------------------------
+ Migration
+-------------------------------------------------------------------------------}
+
+createMigrationPlan
+ :: forall ctx k s.
+ ( HasDBLayer IO s k ctx
+ , HasNetworkLayer IO ctx
+ , HasTransactionLayer k ctx
+ )
+ => ctx
+ -> WalletId
+ -> Withdrawal
+ -> ExceptT ErrCreateMigrationPlan IO MigrationPlan
+createMigrationPlan ctx wid rewardWithdrawal = do
+ (wallet, _, pending) <- withExceptT ErrCreateMigrationPlanNoSuchWallet $
+ readWallet @ctx @s @k ctx wid
+ pp <- liftIO $ currentProtocolParameters nl
+ let txConstraints = view #constraints tl pp
+ let utxo = availableUTxO @s pending wallet
+ pure
+ $ Migration.createPlan txConstraints utxo
+ $ Migration.RewardWithdrawal
+ $ withdrawalToCoin rewardWithdrawal
+ where
+ nl = ctx ^. networkLayer
+ tl = ctx ^. transactionLayer @k
+
+type SelectionResultWithoutChange = SelectionResult Void
+
+migrationPlanToSelectionWithdrawals
+ :: MigrationPlan
+ -> Withdrawal
+ -> NonEmpty Address
+ -> Maybe (NonEmpty (SelectionResultWithoutChange, Withdrawal))
+migrationPlanToSelectionWithdrawals plan rewardWithdrawal outputAddressesToCycle
+ = NE.nonEmpty
+ $ fst
+ $ L.foldr
+ (accumulate)
+ ([], NE.toList $ NE.cycle outputAddressesToCycle)
+ (view #selections plan)
+ where
+ accumulate
+ :: Migration.Selection (TxIn, TxOut)
+ -> ([(SelectionResultWithoutChange, Withdrawal)], [Address])
+ -> ([(SelectionResultWithoutChange, Withdrawal)], [Address])
+ accumulate migrationSelection (selectionWithdrawals, outputAddresses) =
+ ( (selection, withdrawal) : selectionWithdrawals
+ , outputAddressesRemaining
+ )
+ where
+ selection = SelectionResult
+ { inputsSelected = view #inputIds migrationSelection
+ , outputsCovered
+ , utxoRemaining = UTxOIndex.empty
+ , extraCoinSource = Nothing
+ , changeGenerated = []
+ }
+
+ withdrawal =
+ if (view #rewardWithdrawal migrationSelection) > Coin 0
+ then rewardWithdrawal
+ else NoWithdrawal
+
+ outputsCovered :: [TxOut]
+ outputsCovered = zipWith TxOut
+ (outputAddresses)
+ (NE.toList $ view #outputs migrationSelection)
+
+ outputAddressesRemaining :: [Address]
+ outputAddressesRemaining =
+ drop (length $ view #outputs migrationSelection) outputAddresses
+
{-------------------------------------------------------------------------------
Delegation
-------------------------------------------------------------------------------}
@@ -2311,6 +2415,11 @@ data ErrStartTimeLaterThanEndTime = ErrStartTimeLaterThanEndTime
, errEndTime :: UTCTime
} deriving (Show, Eq)
+data ErrCreateMigrationPlan
+ = ErrCreateMigrationPlanEmpty
+ | ErrCreateMigrationPlanNoSuchWallet ErrNoSuchWallet
+ deriving (Generic, Eq, Show)
+
data ErrSelectAssets
= ErrSelectAssetsCriteriaError ErrSelectionCriteria
| ErrSelectAssetsNoSuchWallet ErrNoSuchWallet
diff --git a/lib/core/src/Cardano/Wallet/Api.hs b/lib/core/src/Cardano/Wallet/Api.hs
index d3105c6b12e..254eb379828 100644
--- a/lib/core/src/Cardano/Wallet/Api.hs
+++ b/lib/core/src/Cardano/Wallet/Api.hs
@@ -232,6 +232,8 @@ import Data.Generics.Product.Typed
( HasType, typed )
import Data.Kind
( Type )
+import Data.List.NonEmpty
+ ( NonEmpty )
import GHC.Generics
( Generic )
import Servant.API
@@ -519,7 +521,7 @@ type MigrateShelleyWallet n = "wallets"
:> Capture "walletId" (ApiT WalletId)
:> "migrations"
:> ReqBody '[JSON] (ApiWalletMigrationPostDataT n "raw")
- :> PostAccepted '[JSON] [ApiTransactionT n]
+ :> PostAccepted '[JSON] (NonEmpty (ApiTransactionT n))
-- | https://input-output-hk.github.io/cardano-wallet/api/#operation/createShelleyWalletMigrationPlan
type CreateShelleyWalletMigrationPlan n = "wallets"
@@ -803,7 +805,7 @@ type MigrateByronWallet n = "byron-wallets"
:> Capture "walletId" (ApiT WalletId)
:> "migrations"
:> ReqBody '[JSON] (ApiWalletMigrationPostDataT n "lenient")
- :> PostAccepted '[JSON] [ApiTransactionT n]
+ :> PostAccepted '[JSON] (NonEmpty (ApiTransactionT n))
-- | https://input-output-hk.github.io/cardano-wallet/api/#operation/createByronWalletMigrationPlan
type CreateByronWalletMigrationPlan n = "byron-wallets"
diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
index a3fcafa18ef..eef9b70cdbf 100644
--- a/lib/core/src/Cardano/Wallet/Api/Server.hs
+++ b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -125,6 +125,7 @@ import Cardano.Wallet
, ErrCannotJoin (..)
, ErrCannotQuit (..)
, ErrConstructSharedWallet (..)
+ , ErrCreateMigrationPlan (..)
, ErrCreateRandomAddress (..)
, ErrDecodeSignedTx (..)
, ErrDerivePublicKey (..)
@@ -228,6 +229,7 @@ import Cardano.Wallet.Api.Types
, ApiWalletDelegation (..)
, ApiWalletDelegationNext (..)
, ApiWalletDelegationStatus (..)
+ , ApiWalletMigrationBalance (..)
, ApiWalletMigrationPlan (..)
, ApiWalletMigrationPlanPostData (..)
, ApiWalletMigrationPostData (..)
@@ -326,11 +328,13 @@ import Cardano.Wallet.Primitive.AddressDiscovery.SharedState
)
import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
( SelectionError (..)
- , SelectionInsufficientError (..)
+ , SelectionResult (..)
, UnableToConstructChangeError (..)
, balanceMissing
, selectionDelta
)
+import Cardano.Wallet.Primitive.Migration
+ ( MigrationPlan (..) )
import Cardano.Wallet.Primitive.Model
( Wallet, availableBalance, currentTip, getState, totalBalance )
import Cardano.Wallet.Primitive.Slotting
@@ -412,6 +416,8 @@ import Control.Arrow
( second )
import Control.DeepSeq
( NFData )
+import Control.Error.Util
+ ( failWith )
import Control.Monad
( forM, forever, join, unless, void, when, (>=>) )
import Control.Monad.IO.Class
@@ -466,6 +472,8 @@ import Data.Time
( UTCTime )
import Data.Type.Equality
( (:~:) (..), type (==), testEquality )
+import Data.Void
+ ( Void )
import Data.Word
( Word32 )
import Fmt
@@ -533,6 +541,7 @@ import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Cardano.Wallet.Primitive.Types.Tx as W
+import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
import qualified Cardano.Wallet.Registry as Registry
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
@@ -1746,8 +1755,10 @@ postTransaction ctx genChange (ApiT wid) body = do
w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
sel <- liftHandler
$ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id)
+ sel' <- liftHandler
+ $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel
(tx, txMeta, txTime, sealedTx) <- liftHandler
- $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+ $ W.signTransaction @_ @s @k wrk wid mkRwdAcct pwd txCtx sel'
liftHandler
$ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
pure (sel, tx, txMeta, txTime)
@@ -1904,8 +1915,10 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do
sel <- liftHandler
$ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
$ const Prelude.id
+ sel' <- liftHandler
+ $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel
(tx, txMeta, txTime, sealedTx) <- liftHandler
- $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+ $ W.signTransaction @_ @s @k wrk wid mkRwdAcct pwd txCtx sel'
liftHandler
$ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
@@ -1987,8 +2000,10 @@ quitStakePool ctx (ApiT wid) body = do
sel <- liftHandler
$ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
$ const Prelude.id
+ sel' <- liftHandler
+ $ W.assignChangeAddressesAndUpdateDb wrk wid genChange sel
(tx, txMeta, txTime, sealedTx) <- liftHandler
- $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+ $ W.signTransaction @_ @s @k wrk wid mkRwdAcct pwd txCtx sel'
liftHandler
$ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
@@ -2015,26 +2030,140 @@ quitStakePool ctx (ApiT wid) body = do
-------------------------------------------------------------------------------}
createMigrationPlan
- :: forall n s k. ()
- => ApiLayer s k
- -- ^ Source wallet context
+ :: forall ctx n s k.
+ ( ctx ~ ApiLayer s k
+ , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+ , HardDerivation k
+ , IsOwned s k
+ , Typeable n
+ , Typeable s
+ , WalletKey k
+ )
+ => ctx
-> ApiT WalletId
-- ^ Source wallet
-> ApiWalletMigrationPlanPostData n
+ -- ^ Target addresses
-> Handler (ApiWalletMigrationPlan n)
-createMigrationPlan _ctx _wid _postData = do
- liftHandler $ throwE ErrTemporarilyDisabled
+createMigrationPlan ctx (ApiT wid) postData = do
+ (rewardWithdrawal, _) <- mkRewardAccountBuilder @_ @s @_ @n ctx wid Nothing
+ withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do
+ (wallet, _, _) <- withExceptT ErrCreateMigrationPlanNoSuchWallet $
+ W.readWallet wrk wid
+ plan <- W.createMigrationPlan wrk wid rewardWithdrawal
+ failWith ErrCreateMigrationPlanEmpty $ mkApiWalletMigrationPlan
+ (getState wallet)
+ (view #addresses postData)
+ (rewardWithdrawal)
+ (plan)
+
+mkApiWalletMigrationPlan
+ :: forall n s. IsOurs s Address
+ => s
+ -> NonEmpty (ApiT Address, Proxy n)
+ -> Withdrawal
+ -> MigrationPlan
+ -> Maybe (ApiWalletMigrationPlan n)
+mkApiWalletMigrationPlan s addresses rewardWithdrawal plan =
+ mkApiPlan <$> maybeSelections
+ where
+ mkApiPlan :: NonEmpty (ApiCoinSelection n) -> ApiWalletMigrationPlan n
+ mkApiPlan selections = ApiWalletMigrationPlan
+ { selections
+ , totalFee
+ , balanceLeftover
+ , balanceSelected
+ }
+
+ maybeSelections :: Maybe (NonEmpty (ApiCoinSelection n))
+ maybeSelections = fmap mkApiCoinSelectionForMigration <$> maybeUnsignedTxs
+
+ maybeSelectionWithdrawals
+ :: Maybe (NonEmpty (SelectionResult Void, Withdrawal))
+ maybeSelectionWithdrawals
+ = W.migrationPlanToSelectionWithdrawals plan rewardWithdrawal
+ $ getApiT . fst <$> addresses
+
+ maybeUnsignedTxs = fmap mkUnsignedTx <$> maybeSelectionWithdrawals
+ where
+ mkUnsignedTx (selection, withdrawal) = W.selectionToUnsignedTx
+ withdrawal (selection {changeGenerated = []}) s
+
+ totalFee :: Quantity "lovelace" Natural
+ totalFee = coinToQuantity $ view #totalFee plan
+
+ balanceLeftover :: ApiWalletMigrationBalance
+ balanceLeftover = plan
+ & view #unselected
+ & UTxO.balance
+ & mkApiWalletMigrationBalance
+
+ balanceSelected :: ApiWalletMigrationBalance
+ balanceSelected = plan
+ & view #selections
+ & F.foldMap (view #inputBalance)
+ & mkApiWalletMigrationBalance
+
+ mkApiCoinSelectionForMigration unsignedTx =
+ mkApiCoinSelection [] Nothing Nothing unsignedTx
+
+ mkApiWalletMigrationBalance :: TokenBundle -> ApiWalletMigrationBalance
+ mkApiWalletMigrationBalance b = ApiWalletMigrationBalance
+ { ada = coinToQuantity $ view #coin b
+ , assets = ApiT $ view #tokens b
+ }
migrateWallet
- :: forall s k n p. ()
- => ApiLayer s k
- -- ^ Source wallet context
+ :: forall ctx s k n p.
+ ( ctx ~ ApiLayer s k
+ , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+ , HardDerivation k
+ , HasNetworkLayer IO ctx
+ , IsOwned s k
+ , Typeable n
+ , Typeable s
+ , WalletKey k
+ )
+ => ctx
-> ApiT WalletId
- -- ^ Source wallet
-> ApiWalletMigrationPostData n p
- -> Handler [ApiTransaction n]
-migrateWallet _ctx _wid _migrateData = do
- liftHandler $ throwE ErrTemporarilyDisabled
+ -> Handler (NonEmpty (ApiTransaction n))
+migrateWallet ctx (ApiT wid) postData = do
+ (rewardWithdrawal, mkRewardAccount) <-
+ mkRewardAccountBuilder @_ @s @_ @n ctx wid Nothing
+ withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+ plan <- liftHandler $ W.createMigrationPlan wrk wid rewardWithdrawal
+ txTimeToLive <- liftIO $ W.getTxExpiry ti Nothing
+ selectionWithdrawals <- liftHandler
+ $ failWith ErrCreateMigrationPlanEmpty
+ $ W.migrationPlanToSelectionWithdrawals
+ plan rewardWithdrawal addresses
+ forM selectionWithdrawals $ \(selection, txWithdrawal) -> do
+ let txContext = defaultTransactionCtx
+ { txWithdrawal
+ , txTimeToLive
+ , txDelegationAction = Nothing
+ }
+ (tx, txMeta, txTime, sealedTx) <- liftHandler $
+ W.signTransaction @_ @s @k wrk wid mkRewardAccount pwd txContext
+ (selection {changeGenerated = []})
+ liftHandler $
+ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
+ liftIO $ mkApiTransaction
+ (timeInterpreter (ctx ^. networkLayer))
+ (txId tx)
+ (tx ^. #fee)
+ (NE.toList $ second Just <$> selection ^. #inputsSelected)
+ (tx ^. #outputs)
+ (tx ^. #withdrawals)
+ (txMeta, txTime)
+ (Nothing)
+ (#pendingSince)
+ where
+ addresses = getApiT . fst <$> view #addresses postData
+ pwd = coerce $ getApiT $ postData ^. #passphrase
+ ti :: TimeInterpreter (ExceptT PastHorizonException IO)
+ ti = timeInterpreter (ctx ^. networkLayer)
{-------------------------------------------------------------------------------
Network
@@ -3207,6 +3336,18 @@ instance IsServerError ErrOutputTokenQuantityExceedsLimit where
, "."
]
+instance IsServerError ErrCreateMigrationPlan where
+ toServerError = \case
+ ErrCreateMigrationPlanEmpty ->
+ apiError err403 NothingToMigrate $ mconcat
+ [ "I wasn't able to construct a migration plan. This could be "
+ , "because your wallet is empty, or it could be because the "
+ , "amount of ada in your wallet is insufficient to pay for "
+ , "any of the funds to be migrated. Try adding some ada to "
+ , "your wallet before trying again."
+ ]
+ ErrCreateMigrationPlanNoSuchWallet e -> toServerError e
+
instance IsServerError ErrSelectAssets where
toServerError = \case
ErrSelectAssetsCriteriaError e -> toServerError e
@@ -3234,7 +3375,7 @@ instance IsServerError ErrSelectAssets where
, "because I need to select additional inputs and "
, "doing so will make the transaction too big. Try "
, "sending a smaller amount. I had already selected "
- , showT (length $ inputsSelected e), " inputs."
+ , showT (length $ view #inputsSelected e), " inputs."
]
InsufficientMinCoinValues xs ->
apiError err403 UtxoTooSmall $ mconcat
diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs
index 56bddd352eb..35b1d24458b 100644
--- a/lib/core/src/Cardano/Wallet/Api/Types.hs
+++ b/lib/core/src/Cardano/Wallet/Api/Types.hs
@@ -1026,7 +1026,7 @@ newtype ApiWalletMigrationPlanPostData (n :: NetworkDiscriminant) =
data ApiWalletMigrationPostData (n :: NetworkDiscriminant) (s :: Symbol) =
ApiWalletMigrationPostData
{ passphrase :: !(ApiT (Passphrase s))
- , addresses :: ![(ApiT Address, Proxy n)]
+ , addresses :: !(NonEmpty (ApiT Address, Proxy n))
} deriving (Eq, Generic, Show)
deriving anyclass NFData
diff --git a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs
index 125938e3fc8..38b159ba7f3 100644
--- a/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs
+++ b/lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs
@@ -1686,13 +1686,13 @@ migrateDataCases =
{ "passphrase": #{wPassphrase}
, "addresses": "not_a_array"
}|]
- , "Error in $.addresses: parsing [] failed, expected Array, but encountered String"
+ , "Error in $.addresses: parsing NonEmpty failed, expected Array, but encountered String"
)
, ( [aesonQQ|
{ "passphrase": #{wPassphrase}
, "addresses": 1
}|]
- , "Error in $.addresses: parsing [] failed, expected Array, but encountered Number"
+ , "Error in $.addresses: parsing NonEmpty failed, expected Array, but encountered Number"
)
, ( [aesonQQ|
{ "passphrase": #{wPassphrase}
diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs
index f9190bd276e..e36ddfb6679 100644
--- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs
+++ b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs
@@ -1345,10 +1345,12 @@ instance Arbitrary (ApiWalletMigrationPlanPostData n) where
instance Arbitrary (Passphrase purpose) =>
Arbitrary (ApiWalletMigrationPostData n purpose) where
arbitrary = do
- n <- choose (1,255)
pwd <- arbitrary
- addr <- vector n
- pure $ ApiWalletMigrationPostData pwd ((, Proxy @n) <$> addr)
+ addrCount <- choose (1, 255)
+ addrs <- (:|)
+ <$> arbitrary
+ <*> replicateM (addrCount - 1) arbitrary
+ pure $ ApiWalletMigrationPostData pwd ((, Proxy @n) <$> addrs)
instance Arbitrary ApiWalletPassphrase where
arbitrary = genericArbitrary
diff --git a/lib/core/test/unit/Cardano/WalletSpec.hs b/lib/core/test/unit/Cardano/WalletSpec.hs
index dcde1f57c5a..c31860cdaf4 100644
--- a/lib/core/test/unit/Cardano/WalletSpec.hs
+++ b/lib/core/test/unit/Cardano/WalletSpec.hs
@@ -587,11 +587,13 @@ walletKeyIsReencrypted (wid, wname) (xprv, pwd) newPwd =
unsafeRunExceptT $ W.attachPrivateKeyFromPwd wl wid (xprv, pwd)
let credentials (rootK, pwdP) =
(getRawKey $ deriveRewardAccount pwdP rootK, pwdP)
- (_,_,_,txOld) <- unsafeRunExceptT $
- W.signTransaction @_ @_ wl wid () credentials (coerce pwd) ctx selection
+ selection' <- unsafeRunExceptT $
+ W.assignChangeAddressesAndUpdateDb wl wid () selection
+ (_,_,_,txOld) <- unsafeRunExceptT $ W.signTransaction
+ @_ @_ wl wid credentials (coerce pwd) ctx selection'
unsafeRunExceptT $ W.updateWalletPassphrase wl wid (coerce pwd, newPwd)
- (_,_,_,txNew) <- unsafeRunExceptT $
- W.signTransaction @_ @_ wl wid () credentials newPwd ctx selection
+ (_,_,_,txNew) <- unsafeRunExceptT $ W.signTransaction
+ @_ @_ wl wid credentials newPwd ctx selection'
txOld `shouldBe` txNew
where
selection = SelectionResult
diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml
index 566f8b2e4de..e4a93049b23 100644
--- a/specifications/api/swagger.yaml
+++ b/specifications/api/swagger.yaml
@@ -3686,8 +3686,8 @@ x-responsesCreateWalletMigrationPlan: &responsesCreateWalletMigrationPlan
schema: *errNothingToMigrate
<<: *responsesErr404WalletNotFound
<<: *responsesErr406
- 200:
- description: Ok
+ 202:
+ description: Accepted
content:
application/json:
schema: *ApiWalletMigrationPlan
@@ -3705,13 +3705,14 @@ x-responsesMigrateWallet: &responsesMigrateWallet
<<: *responsesErr404WalletNotFound
<<: *responsesErr406
<<: *responsesErr415UnsupportedMediaType
- 200:
- description: Ok
+ 202:
+ description: Accepted
content:
application/json:
schema:
type: array
items: *ApiTransaction
+ minItems: 1
x-responsesDeleteWallet: &responsesDeleteWallet
<<: *responsesErr400
@@ -4656,10 +4657,6 @@ paths:
tags: ["Migrations"]
summary: Migrate
description: |
- status: disabled
- ⚠️IMPORTANT⚠️ This endpoint has been temporarily disabled with the introduction of multi-assets UTxO. It will be enabled again soon.
-
-
Migrate the UTxO balance of this wallet to the given set of addresses.
This operation will attempt to transfer as much of the wallet's balance
@@ -4694,10 +4691,6 @@ paths:
tags: ["Migrations"]
summary: Create a migration plan
description: |
- status: disabled
- ⚠️IMPORTANT⚠️ This endpoint has been temporarily disabled with the introduction of multi-assets UTxO. It will be enabled again soon.
-
-
Generate a plan for migrating the UTxO balance of this wallet to
another wallet, without executing the plan.