From aad8f36342cf5cddf9c782b3ddc85dc741aa0eac Mon Sep 17 00:00:00 2001 From: paolino Date: Fri, 8 Nov 2024 12:17:10 +0000 Subject: [PATCH] Add addresses codec to deposit wallet --- .../customer-deposit-wallet.cabal | 9 +- .../Wallet/Deposit/Pure/API/Address.hs | 211 ++++++++++++++++++ .../Wallet/Deposit/Pure/API/AddressSpec.hs | 44 ++++ 3 files changed, 263 insertions(+), 1 deletion(-) create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs create mode 100644 lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index dbc7e41e718..d254f6077ff 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -54,6 +54,10 @@ library build-depends: , async , base + , base58-bytestring + , bech32 + , bech32-th + , bytestring , cardano-balance-tx , cardano-crypto , cardano-ledger-api @@ -72,9 +76,9 @@ library , fingertree , io-classes , microlens + , MonadRandom , monoidal-containers , mtl - , MonadRandom , mwc-random , OddWord , random @@ -92,6 +96,7 @@ library Cardano.Wallet.Deposit.Map Cardano.Wallet.Deposit.Map.Timed Cardano.Wallet.Deposit.Pure + Cardano.Wallet.Deposit.Pure.API.Address Cardano.Wallet.Deposit.Pure.API.TxHistory Cardano.Wallet.Deposit.Pure.API.TxHistory.Mock Cardano.Wallet.Deposit.Pure.Balance @@ -194,6 +199,7 @@ test-suite unit , base , bytestring , cardano-crypto + , cardano-ledger-core:testlib , cardano-wallet-read , cardano-wallet-test-utils , containers @@ -216,6 +222,7 @@ test-suite unit Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec Cardano.Wallet.Deposit.HTTP.OpenAPISpec Cardano.Wallet.Deposit.Map.TimedSpec + Cardano.Wallet.Deposit.Pure.API.AddressSpec Cardano.Wallet.Deposit.PureSpec Cardano.Wallet.Deposit.RESTSpec Paths_customer_deposit_wallet diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs new file mode 100644 index 00000000000..142253fb65c --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Wallet.Deposit.Pure.API.Address + ( encodeAddress + , decodeAddress + , DecodingError (..) + , NetworkTag (..) + , getNetworkTag + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.Read + ( Address + , NetworkTag (..) + ) +import Cardano.Wallet.Primitive.Ledger.Shelley + ( StandardCrypto + ) +import Cardano.Wallet.Read.Address + ( toShortByteString + ) +import Codec.Binary.Bech32 + ( DataPart + , HumanReadablePart + , dataPartFromBytes + , dataPartToBytes + , decodeLenient + ) +import Control.Arrow + ( ArrowChoice (..) + ) +import Control.Monad + ( (>=>) + ) +import Control.Monad.State.Strict + ( evalStateT + ) +import Data.ByteString + ( ByteString + ) +import Data.ByteString.Base58 + ( bitcoinAlphabet + , decodeBase58 + , encodeBase58 + ) +import Data.Text + ( Text + ) + +import qualified Cardano.Ledger.Address as SH +import qualified Cardano.Ledger.Address as SL +import qualified Cardano.Ledger.BaseTypes as SL +import qualified Codec.Binary.Bech32 as Bech32 +import qualified Codec.Binary.Bech32.TH as Bech32 +import qualified Data.ByteString.Short as B8 +import qualified Data.Text.Encoding as T + +data AddressFlavor a b + = Bootstrap + {bootstrapFlavor :: a} + | Shelley + {shelleyFlavor :: b} + deriving (Eq, Show) + +withAddressFlavor + :: (a -> c) + -> (b -> c) + -> AddressFlavor a b + -> c +withAddressFlavor f _ (Bootstrap x) = f x +withAddressFlavor _ g (Shelley x) = g x + +-- | Errors that can occur when decoding an 'Address'. +data DecodingError + = InvalidBech32Encoding Bech32.DecodingError + | InvalidBase58Encoding + | InvalidHumanReadablePart HumanReadablePart + | InvalidDataPart DataPart + | InvalidNetwork + | AddressFlavorMismatch + | AddressDecodingError String + | AddressNetworkMismatch + deriving (Eq, Show) + +humanPart :: NetworkTag -> HumanReadablePart +humanPart = \case + MainnetTag -> [Bech32.humanReadablePart|addr|] + TestnetTag -> [Bech32.humanReadablePart|addr_test|] + +decodeBase58Address + :: ByteString + -> Either + DecodingError + ( AddressFlavor + ByteString + (ByteString, HumanReadablePart) + ) +decodeBase58Address = + fmap Bootstrap + . maybe (Left InvalidBase58Encoding) Right + . decodeBase58 bitcoinAlphabet + +decodeBech32Address + :: Text + -> Either + DecodingError + (AddressFlavor ByteString (ByteString, HumanReadablePart)) +decodeBech32Address bech32 = do + (hrp, dataPart) <- left InvalidBech32Encoding $ decodeLenient bech32 + case dataPartToBytes dataPart of + Nothing -> Left $ InvalidDataPart dataPart + Just bytes -> pure $ Shelley (bytes, hrp) + +decodeHumanAddress + :: Text + -> Either + DecodingError + (AddressFlavor ByteString (ByteString, HumanReadablePart)) +decodeHumanAddress t = + decodeBech32Address t + <> decodeBase58Address (T.encodeUtf8 t) + +newtype CatchFail a = CatchFail {runCatchFail :: Either String a} + deriving (Functor, Applicative, Monad) + +instance MonadFail CatchFail where + fail = CatchFail . Left + +ledgerAddressFlavor :: SL.Addr c -> AddressFlavor () () +ledgerAddressFlavor (SL.AddrBootstrap _) = Bootstrap () +ledgerAddressFlavor _ = Shelley () + +ledgerAddressNetworkTag :: SL.Addr c -> NetworkTag +ledgerAddressNetworkTag addr = case SL.getNetwork addr of + SL.Testnet -> TestnetTag + SL.Mainnet -> MainnetTag + +-- | Get the network tag of an 'Address'. +getNetworkTag :: Address -> NetworkTag +getNetworkTag = ledgerAddressNetworkTag . SL.decompactAddr + +ledgerDecode + :: ByteString + -> Either DecodingError (SL.Addr StandardCrypto) +ledgerDecode bs = + left AddressDecodingError + $ runCatchFail + $ evalStateT + (SH.decodeAddrStateLenientT @StandardCrypto True True bs) + 0 + +inspectAddress + :: AddressFlavor ByteString (ByteString, HumanReadablePart) + -> Either DecodingError (AddressFlavor Address Address) +inspectAddress (Bootstrap a) = do + r <- ledgerDecode a + case ledgerAddressFlavor r of + Bootstrap () -> + pure (Bootstrap $ SH.compactAddr r) + _ -> Left AddressFlavorMismatch +inspectAddress (Shelley (bytes, hrp)) = do + r <- ledgerDecode bytes + case (ledgerAddressNetworkTag r, ledgerAddressFlavor r) of + (network, Shelley ()) -> + if humanPart network == hrp + then pure (Shelley $ SH.compactAddr r) + else Left AddressNetworkMismatch + _ -> Left AddressFlavorMismatch + +decodeFlavoredAddress + :: Text + -> Either DecodingError (AddressFlavor Address Address) +decodeFlavoredAddress = decodeHumanAddress >=> inspectAddress + +-- | Decode an 'Address' from a 'Text' representation. +decodeAddress + :: Text + -- ^ Text to decode + -> Either DecodingError Address +decodeAddress text = withAddressFlavor id id <$> decodeFlavoredAddress text + +addFlavorToAddress :: Address -> AddressFlavor Address Address +addFlavorToAddress x + | SL.isBootstrapCompactAddr x = Bootstrap x + | otherwise = Shelley x + +encodeFlavoredAddress + :: AddressFlavor Address Address + -> Text +encodeFlavoredAddress (Shelley addr) = bech32 + where + bytes = B8.fromShort $ toShortByteString addr + bech32 = Bech32.encodeLenient hrp (dataPartFromBytes bytes) + hrp = humanPart $ getNetworkTag addr +encodeFlavoredAddress (Bootstrap addr) = + T.decodeUtf8 . encodeBase58 bitcoinAlphabet + $ B8.fromShort + $ toShortByteString addr + +-- | Encode an 'Address' to a 'Text' representation. +encodeAddress + :: Address + -- ^ Address to encode + -> Text +encodeAddress = encodeFlavoredAddress . addFlavorToAddress diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs new file mode 100644 index 00000000000..7e4df142b01 --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs @@ -0,0 +1,44 @@ +module Cardano.Wallet.Deposit.Pure.API.AddressSpec + ( spec + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.Pure.API.Address + ( decodeAddress + , encodeAddress + ) +import Control.Monad + ( forM_ + ) +import Test.Cardano.Ledger.Core.Arbitrary + () +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + ) +import Test.QuickCheck + ( Arbitrary (..) + , forAll + , (===) + ) + +spec :: Spec +spec = do + describe "address codec" $ do + it "rountrips correctly on random addresses" $ forAll arbitrary $ \x -> + decodeAddress (encodeAddress x) + === Right x + it "roundtrips correctly on some addresses from online examples" + $ do + let testCases = + [ "addr1z92l7rnra7sxjn5qv5fzc4fwsrrm29mgkleqj9a0y46j5lyjz4gwd3njhyqwntdkcm8rrgapudajydteywgtuvl6etjs9nqzg5" + , "addr_test1wppg9l6relcpls4u667twqyggkrpfrs5cdge9hhl9cv2upchtch0h" + , "37btjrVyb4KDXBNC4haBVPCrro8AQPHwvCMp3RFhhSVWwfFmZ6wwzSK6JK1hY6wHNmtrpTf1kdbva8TCneM2YsiXT7mrzT21EacHnPpz5YyUdj64na" + ] + forM_ testCases $ \addr -> + encodeAddress <$> decodeAddress addr + `shouldBe` Right addr