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. - -status: disabled
- ⚠️IMPORTANT⚠️ This endpoint has been temporarily disabled with the introduction of multi-assets UTxO. It will be enabled again soon. - -