Add input bip32 list to Transaction type

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
 

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

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