diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal index 5964b678622..a3d3ae7a0d1 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/lib/ui/cardano-wallet-ui.cabal @@ -12,6 +12,7 @@ extra-doc-files: CHANGELOG.md data-files: data/english.txt data/images/*.png + golden/*.json common language default-language: Haskell2010 @@ -134,8 +135,7 @@ library , containers , contra-tracer , cookie - , customer-deposit-wallet - , customer-deposit-wallet:rest + , customer-deposit-wallet:{customer-deposit-wallet, rest} , exceptions , generic-lens , hashable @@ -183,9 +183,9 @@ test-suite unit , cardano-wallet-ui , containers , contra-tracer - , customer-deposit-wallet - , customer-deposit-wallet:rest + , customer-deposit-wallet:{customer-deposit-wallet, rest} , hspec + , hspec-golden-aeson , mtl , QuickCheck , temporary diff --git a/lib/ui/golden/BIP32Path.json b/lib/ui/golden/BIP32Path.json new file mode 100644 index 00000000000..55e75f3202c --- /dev/null +++ b/lib/ui/golden/BIP32Path.json @@ -0,0 +1,10 @@ +{ + "samples": [ + "", + "1911087457/2025199967H", + "", + "9886650H/131789259H", + "1324835599H" + ], + "seed": 300465375 +} \ No newline at end of file diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs index 896a65e1b62..46da7ce17dd 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,6 +15,11 @@ where import Prelude +import Cardano.Wallet.Deposit.Pure + ( BIP32Path (..) + , DerivationType (..) + , Word31 + ) import Cardano.Wallet.Deposit.Pure.API.Address ( encodeAddress ) @@ -29,8 +35,13 @@ import Data.Aeson , ToJSON (toJSON) , object , withObject + , withText , (.:) ) +import Data.Aeson.Types + ( Parser + , parseFail + ) import Data.Map.Monoidal.Strict ( MonoidalMap ) @@ -61,13 +72,13 @@ import Web.FormUrlEncoded import qualified Data.Aeson as Aeson import qualified Data.Map.Monoidal.Strict as MonoidalMap -import qualified Data.Text.Lazy as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL newtype NewReceiver = NewReceiver Receiver -data AddReceiverForm - = AddReceiverForm +data AddReceiverForm = AddReceiverForm { newReceiver :: NewReceiver , addReceiverState :: State } @@ -99,20 +110,21 @@ instance FromForm NewReceiverValidation where amountValidation <- parseMaybe "new-receiver-amount" form pure $ NewReceiverValidation{addressValidation, amountValidation} -data Transaction - = Transaction - { dataType :: Text - , description :: Text - , cborHex :: Text +data Transaction = Transaction + { dataType :: !Text + , description :: !Text + , cborHex :: !Text + , bip32Paths :: ![BIP32Path] } - deriving (Eq, Show) + deriving (Eq, Show, Generic) instance ToJSON Transaction where - toJSON Transaction{dataType, description, cborHex} = + toJSON Transaction{dataType, description, cborHex, bip32Paths} = object [ "type" .= dataType , "description" .= description , "cborHex" .= cborHex + , "bip32Paths" .= bip32Paths ] instance FromJSON Transaction where @@ -120,12 +132,54 @@ instance FromJSON Transaction where dataType <- o .: "type" description <- o .: "description" cborHex <- o .: "cborHex" - pure Transaction{dataType, description, cborHex} + bip32Paths <- o .: "bip32Paths" + pure Transaction{dataType, description, cborHex, bip32Paths} + +-- Orphan instances for BIP32Path +-- TODO: move where they belong, in the module defining BIP32Path +instance ToJSON BIP32Path where + toJSON = toJSON . encodeBIP32 + where + encodeBIP32 = \case + (Segment Root Hardened n) -> T.pack (show n) <> "H" + (Segment Root Soft n) -> T.pack (show n) + (Segment p Hardened n) -> + encodeBIP32 p + <> "/" + <> T.pack (show n) + <> "H" + (Segment p Soft n) -> + encodeBIP32 p <> "/" <> T.pack (show n) + Root -> "" + +instance FromJSON BIP32Path where + parseJSON = withText "BIP32Path" parseBip32 + where + parseBip32 :: Text -> Parser BIP32Path + parseBip32 t = case T.splitOn "/" t of + [""] -> pure Root + xs -> foldSegments <$> traverse parseSegment xs + + foldSegments :: [(Word31, DerivationType)] -> BIP32Path + foldSegments = foldl (\p (i, t) -> Segment p t i) Root + + parseSegment :: Text -> Parser (Word31, DerivationType) + parseSegment t = case T.stripSuffix "H" t of + Nothing -> do + s <- parseIndex t + pure (s, Soft) + Just t' -> do + s <- parseIndex t' + pure (s, Hardened) + where + parseIndex :: Text -> Parser Word31 + parseIndex text = case reads $ T.unpack text of + [(i, "")] -> pure i + _ -> parseFail "Invalid index" newtype Password = Password Text -data SignatureForm - = SignatureForm +data SignatureForm = SignatureForm { signatureFormState :: State , signaturePassword :: Password } @@ -150,7 +204,7 @@ instance FromJSON State instance FromHttpApiData State where parseQueryParam :: Text -> Either Text State - parseQueryParam t = case Aeson.decode $ TL.encodeUtf8 $ T.fromStrict t of + parseQueryParam t = case Aeson.decode $ TL.encodeUtf8 $ TL.fromStrict t of Nothing -> Left "Invalid JSON for a State" Just tx -> pure tx diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs index 102a4c93e27..fb1c4a49c57 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs @@ -18,7 +18,8 @@ import Cardano.Wallet.Deposit.IO.Network.Type ( ErrPostTx ) import Cardano.Wallet.Deposit.Pure - ( CanSign + ( BIP32Path + , CanSign , ErrCreatePayment , InspectTx (..) ) @@ -35,6 +36,7 @@ import Cardano.Wallet.Deposit.REST , availableBalance , canSign , createPayment + , getBIP32PathsForOwnedInputs , inspectTx , networkTag , resolveCurrentEraTx @@ -168,7 +170,8 @@ signPayment serializedTx (Password pwd) = do case mSignedTx of Nothing -> ExceptT $ pure $ Left PrivateKeyIsMissing Just signedTx -> do - pure $ serializeTransaction signedTx + paths <- lift $ getBIP32PathsForOwnedInputs signedTx + pure $ serializeTransaction paths signedTx receiversPayment :: Transaction -> ExceptT PaymentError WalletResourceM Receivers @@ -189,11 +192,16 @@ unsignedPayment receivers = do pure (address, ValueC (CoinC $ fromIntegral amount) mempty) case er of Left e -> ExceptT $ pure $ Left $ CreatePaymentError e - Right rtx -> pure $ serializeTransaction $ resolvedTx rtx + Right rtx -> do + paths <- lift $ getBIP32PathsForOwnedInputs $ resolvedTx rtx + pure $ serializeTransaction paths $ resolvedTx rtx -serializeTransaction :: Tx -> Transaction -serializeTransaction = - conwayEraTransactionExport +serializeTransaction + :: [BIP32Path] + -> Tx + -> Transaction +serializeTransaction paths = + conwayEraTransactionExport paths . T.decodeUtf8 . B16.encode . BL.toStrict @@ -259,12 +267,13 @@ signalHandler layer alert render state signal = do $ case r of x -> x -conwayEraTransactionExport :: Text -> Transaction -conwayEraTransactionExport cborHex = +conwayEraTransactionExport :: [BIP32Path] -> Text -> Transaction +conwayEraTransactionExport bip32Paths cborHex = Transaction { dataType = "Unwitnessed Tx ConwayEra" , description = "Ledger Cddl Format" , cborHex + , bip32Paths } data AddressValidationResponse diff --git a/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs b/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs index 7067cadb6cd..497a3b2d773 100644 --- a/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs +++ b/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Wallet.UI.Deposit.Html.Pages.Payments.PageSpec ( spec @@ -28,7 +30,9 @@ import Cardano.Wallet.Deposit.IO.Resource ( withResource ) import Cardano.Wallet.Deposit.Pure - ( Credentials + ( BIP32Path (..) + , Credentials + , DerivationType (..) ) import Cardano.Wallet.Deposit.Pure.State.Creation ( createMnemonicFromWords @@ -86,6 +90,20 @@ import Test.Hspec ) import qualified Cardano.Wallet.Deposit.Read as Read +import Data.Data + ( Proxy (..) + ) +import Test.Aeson.GenericSpecs + ( roundtripAndGoldenSpecs + ) +import Test.QuickCheck + ( Arbitrary + , choose + , oneof + ) +import Test.QuickCheck.Arbitrary + ( Arbitrary (..) + ) fakeBootEnv :: IO (WalletBootEnv IO) fakeBootEnv = do @@ -93,7 +111,8 @@ fakeBootEnv = do pure $ WalletBootEnv nullTracer Read.mockGenesisDataMainnet net mnemonics :: Text -mnemonics = "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" +mnemonics = + "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" seed :: SomeMnemonic Right seed = createMnemonicFromWords mnemonics @@ -148,3 +167,17 @@ spec = do change `shouldNotBe` [] ourInputs `shouldNotBe` [] fee `shouldNotBe` 0 + describe "BIP32 input paths" + $ roundtripAndGoldenSpecs (Proxy @BIP32Path) + +instance Arbitrary DerivationType where + arbitrary = oneof [pure Soft, pure Hardened] + +instance Arbitrary BIP32Path where + arbitrary = oneof [pure Root, segment] + where + segment = do + path <- arbitrary + derivation <- arbitrary + index <- fromIntegral <$> choose (0 :: Int, 2 ^ (31 :: Int) - 1) + pure $ Segment path derivation index