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

@@ -134,8 +134,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 +182,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 #-}
@@ -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
     }

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

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 - 1)
+            pure $ Segment path derivation index