[ADP-3479] Add addresses codec to deposit wallet (#4836)

- Add decoding and encoding between ledger addresses and bech32 or
base58 under a network constraint to deposit wallet lib

ADP-3479

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

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

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