From 4a39c7b255c64a68f5dcea3111da8ac41669bfb7 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 14 Dec 2024 09:42:23 +0100 Subject: [PATCH] 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 | 7 +- lib/ui/golden/BIP32Path.json | 10 ++ .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 113 +++++++++--------- .../Deposit/Handlers/Payments/Transaction.hs | 10 +- .../Deposit/Html/Pages/Payments/PageSpec.hs | 52 ++++---- 5 files changed, 95 insertions(+), 97 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..9390e30fe8c 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/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 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..7b49db219ae 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 @@ -27,9 +27,6 @@ import Cardano.Wallet.Deposit.Pure.API.Address ( NetworkTag (..) , getNetworkTag ) -import Cardano.Wallet.Deposit.Read - ( Address - ) import Cardano.Wallet.Deposit.REST ( WalletResource , WalletResourceM @@ -43,6 +40,9 @@ import Cardano.Wallet.Deposit.REST , signTx , submitTx ) +import Cardano.Wallet.Deposit.Read + ( Address + ) import Cardano.Wallet.Deposit.Write ( Tx , resolvedTx @@ -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..ac6c1f54556 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,14 @@ 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 +143,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 +157,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