[ADP-3479] Add input bip32 list to Transaction type

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

lib/ui/golden/BIP32Path.json

@@ -0,0 +1,10 @@
+{
+    "samples": [
+        "",
+        "1911087457/2025199967H",
+        "",
+        "9886650H/131789259H",
+        "1324835599H"
+    ],
+    "seed": 300465375
+}

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,33 +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
+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
     parseJSON = withObject "Transaction" $ \o -> do
         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
 

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

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,14 +90,29 @@ 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
     net <- mapBlock Read.EraValue <$> newNetworkEnvMock
     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