From 09670168f564d8d84308e438ee778736e31e3f95 Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 3 Dec 2024 13:45:52 +0000 Subject: [PATCH 1/2] Add input bip32 list to Transaction type --- .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 63 +++++++++++++++++-- .../Deposit/Handlers/Payments/Transaction.hs | 25 +++++--- .../Deposit/Html/Pages/Payments/PageSpec.hs | 39 +++++++++++- 3 files changed, 112 insertions(+), 15 deletions(-) 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..dbda11726b8 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs @@ -14,6 +14,11 @@ where import Prelude +import Cardano.Wallet.Deposit.Pure + ( BIP32Path (..) + , DerivationType (..) + , Word31 + ) import Cardano.Wallet.Deposit.Pure.API.Address ( encodeAddress ) @@ -31,6 +36,11 @@ import Data.Aeson , withObject , (.:) ) +import Data.Aeson.Types + ( Parser + , parseEither + , parseFail + ) import Data.Map.Monoidal.Strict ( MonoidalMap ) @@ -42,6 +52,7 @@ import Data.Text ) import GHC.Generics ( Generic + , S ) import Numeric.Natural ( Natural @@ -61,7 +72,8 @@ 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 @@ -104,23 +116,66 @@ data Transaction { dataType :: Text , description :: Text , cborHex :: Text + , inputBip32Paths :: [BIP32Path] } deriving (Eq, Show) instance ToJSON Transaction where - toJSON Transaction{dataType, description, cborHex} = + toJSON Transaction{dataType, description, cborHex, inputBip32Paths} = object [ "type" .= dataType , "description" .= description , "cborHex" .= cborHex + , "bip32Paths" .= (encodeBip32 <$> inputBip32Paths) ] +encodeBip32 :: BIP32Path -> Text +encodeBip32 (Segment Root Hardened n) = + T.pack (show n) + <> "H" +encodeBip32 (Segment Root Soft n) = + T.pack (show n) +encodeBip32 (Segment p Hardened n) = + encodeBip32 p + <> "/" + <> T.pack (show n) + <> "H" +encodeBip32 (Segment p Soft n) = + encodeBip32 p <> "/" <> T.pack (show n) +encodeBip32 Root = "" + instance FromJSON Transaction where parseJSON = withObject "Transaction" $ \o -> do dataType <- o .: "type" description <- o .: "description" cborHex <- o .: "cborHex" - pure Transaction{dataType, description, cborHex} + inputBip32Paths <- o .: "bip32Paths" >>= traverse parseBip32 + pure Transaction{dataType, description, cborHex, inputBip32Paths} + +decodeBip32 :: Text -> Either String BIP32Path +decodeBip32 = parseEither parseBip32 + +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" + +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 newtype Password = Password Text @@ -150,7 +205,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..1bcd256325a 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 inputBip32Paths cborHex = Transaction { dataType = "Unwitnessed Tx ConwayEra" , description = "Ledger Cddl Format" , cborHex + , inputBip32Paths } 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..4ef93d4657d 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 @@ -28,7 +28,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 @@ -54,7 +56,9 @@ import Cardano.Wallet.Deposit.Write , mkTxOut ) import Cardano.Wallet.UI.Deposit.API.Payments - ( unsigned + ( decodeBip32 + , encodeBip32 + , unsigned ) import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction ( deserializeTransaction @@ -82,6 +86,7 @@ import Test.Hspec ( Spec , describe , it + , shouldBe , shouldNotBe ) @@ -93,7 +98,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 @@ -134,6 +140,26 @@ fundTheWallet network = do Right () <- liftIO $ postTx network tx pure () +customer0 :: BIP32Path +customer0 = + ( Segment + ( Segment + ( Segment + ( Segment + (Segment Root Hardened 1857) + Hardened + 1815 + ) + Hardened + 0 + ) + Soft + 0 + ) + Soft + 0 + ) + spec :: Spec spec = do describe "payment" $ do @@ -148,3 +174,10 @@ spec = do change `shouldNotBe` [] ourInputs `shouldNotBe` [] fee `shouldNotBe` 0 + describe "inputh paths" $ do + it "has a json encoding" + $ do + encodeBip32 customer0 `shouldBe` "1857H/1815H/0H/0/0" + it "can be decoded after encoding" $ do + decodeBip32 "1857H/1815H/0H/0/0" + `shouldBe` Right customer0 From 407f32cefbd15bafc756b5a6d383ab426efdde6e Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 14 Dec 2024 09:42:23 +0100 Subject: [PATCH 2/2] Add roundtrip JSON property tests for BIP32Path The ToJSON/FromJSON/Arbitrary instances for BIP32Path should probably live alongside the corresponding datatype definition but it's good enough for now. Interestingly, writing the property showed a bug: The parsing of `Root` path was incorrect! --- lib/ui/cardano-wallet-ui.cabal | 8 +- lib/ui/golden/BIP32Path.json | 10 ++ .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 113 +++++++++--------- .../Deposit/Handlers/Payments/Transaction.hs | 4 +- .../Deposit/Html/Pages/Payments/PageSpec.hs | 62 +++++----- 5 files changed, 103 insertions(+), 94 deletions(-) create mode 100644 lib/ui/golden/BIP32Path.json 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 dbda11726b8..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 #-} @@ -34,11 +35,11 @@ import Data.Aeson , ToJSON (toJSON) , object , withObject + , withText , (.:) ) import Data.Aeson.Types ( Parser - , parseEither , parseFail ) import Data.Map.Monoidal.Strict @@ -52,7 +53,6 @@ import Data.Text ) import GHC.Generics ( Generic - , S ) import Numeric.Natural ( Natural @@ -78,8 +78,7 @@ import qualified Data.Text.Lazy.Encoding as TL newtype NewReceiver = NewReceiver Receiver -data AddReceiverForm - = AddReceiverForm +data AddReceiverForm = AddReceiverForm { newReceiver :: NewReceiver , addReceiverState :: State } @@ -111,76 +110,76 @@ instance FromForm NewReceiverValidation where amountValidation <- parseMaybe "new-receiver-amount" form pure $ NewReceiverValidation{addressValidation, amountValidation} -data Transaction - = Transaction - { dataType :: Text - , description :: Text - , cborHex :: Text - , inputBip32Paths :: [BIP32Path] +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, inputBip32Paths} = + toJSON Transaction{dataType, description, cborHex, bip32Paths} = object [ "type" .= dataType , "description" .= description , "cborHex" .= cborHex - , "bip32Paths" .= (encodeBip32 <$> inputBip32Paths) + , "bip32Paths" .= bip32Paths ] -encodeBip32 :: BIP32Path -> Text -encodeBip32 (Segment Root Hardened n) = - T.pack (show n) - <> "H" -encodeBip32 (Segment Root Soft n) = - T.pack (show n) -encodeBip32 (Segment p Hardened n) = - encodeBip32 p - <> "/" - <> T.pack (show n) - <> "H" -encodeBip32 (Segment p Soft n) = - encodeBip32 p <> "/" <> T.pack (show n) -encodeBip32 Root = "" - instance FromJSON Transaction where parseJSON = withObject "Transaction" $ \o -> do dataType <- o .: "type" description <- o .: "description" cborHex <- o .: "cborHex" - inputBip32Paths <- o .: "bip32Paths" >>= traverse parseBip32 - pure Transaction{dataType, description, cborHex, inputBip32Paths} - -decodeBip32 :: Text -> Either String BIP32Path -decodeBip32 = parseEither parseBip32 - -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" - -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 + 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 } 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 1bcd256325a..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 @@ -268,12 +268,12 @@ signalHandler layer alert render state signal = do x -> x conwayEraTransactionExport :: [BIP32Path] -> Text -> Transaction -conwayEraTransactionExport inputBip32Paths cborHex = +conwayEraTransactionExport bip32Paths cborHex = Transaction { dataType = "Unwitnessed Tx ConwayEra" , description = "Ledger Cddl Format" , cborHex - , inputBip32Paths + , 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 4ef93d4657d..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 @@ -56,9 +58,7 @@ import Cardano.Wallet.Deposit.Write , mkTxOut ) import Cardano.Wallet.UI.Deposit.API.Payments - ( decodeBip32 - , encodeBip32 - , unsigned + ( unsigned ) import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction ( deserializeTransaction @@ -86,11 +86,24 @@ import Test.Hspec ( Spec , describe , it - , shouldBe , shouldNotBe ) 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 @@ -140,26 +153,6 @@ fundTheWallet network = do Right () <- liftIO $ postTx network tx pure () -customer0 :: BIP32Path -customer0 = - ( Segment - ( Segment - ( Segment - ( Segment - (Segment Root Hardened 1857) - Hardened - 1815 - ) - Hardened - 0 - ) - Soft - 0 - ) - Soft - 0 - ) - spec :: Spec spec = do describe "payment" $ do @@ -174,10 +167,17 @@ spec = do change `shouldNotBe` [] ourInputs `shouldNotBe` [] fee `shouldNotBe` 0 - describe "inputh paths" $ do - it "has a json encoding" - $ do - encodeBip32 customer0 `shouldBe` "1857H/1815H/0H/0/0" - it "can be decoded after encoding" $ do - decodeBip32 "1857H/1815H/0H/0/0" - `shouldBe` Right customer0 + 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