Merge pull request #336 from input-output-hk/KtorZ/239/address-format…

…-in-shelley-era

Address Format in Shelley (Part 2: implementing address encoder and decoders + tests)

lib/bech32/src/Codec/Binary/Bech32.hs

@@ -14,7 +14,11 @@ module Codec.Binary.Bech32
     (
       -- * Encoding & Decoding
       encode
+    , encodeLenient
+    , EncodingError (..)
     , decode
+    , decodeLenient
+    , DecodingError (..)
 
       -- * Data Part
     , DataPart
@@ -25,9 +29,9 @@ module Codec.Binary.Bech32
 
       -- * Human-Readable Part
     , HumanReadablePart
+    , HumanReadablePartError (..)
     , humanReadablePartFromText
     , humanReadablePartToText
-
     ) where
 
 import Codec.Binary.Bech32.Internal

lib/bech32/src/Codec/Binary/Bech32/Internal.hs

@@ -22,8 +22,10 @@ module Codec.Binary.Bech32.Internal
     (
       -- * Encoding & Decoding
       encode
+    , encodeLenient
     , EncodingError (..)
     , decode
+    , decodeLenient
     , DecodingError (..)
     , checksumLength
     , encodedStringMaxLength
@@ -293,27 +295,40 @@ humanReadableCharMaxBound = chr 126
                             Encoding & Decoding
 -------------------------------------------------------------------------------}
 
+-- | Like 'encode' but allows output to be longer than 90 characters. This isn't
+-- ideal as the error detection becomes worse as string get longer but it's
+-- still acceptable.
+--
+-- From BIP-0173:
+--
+--     Even though the chosen code performs reasonably well up to 1023
+--     characters, other designs are preferable for lengths above 89
+--     characters (excluding the separator).
+--
+encodeLenient :: HumanReadablePart -> DataPart -> Text
+encodeLenient hrp dp = humanReadablePartToText hrp
+    <> T.singleton separatorChar
+    <> T.pack dcp
+  where
+    dcp = dataCharFromWord <$> dataPartToWords dp <> createChecksum hrp dp
+
 -- | Encode a human-readable string and data payload into a Bech32 string.
 encode :: HumanReadablePart -> DataPart -> Either EncodingError Text
 encode hrp dp
     | T.length result > encodedStringMaxLength = Left EncodedStringTooLong
     | otherwise = pure result
   where
-    result = humanReadablePartToText hrp
-        <> T.singleton separatorChar
-        <> T.pack dcp
-    dcp = dataCharFromWord <$> dataPartToWords dp <> createChecksum hrp dp
+    result = encodeLenient hrp dp
 
 -- | Represents the set of error conditions that may occur while encoding a
 --   Bech32 string.
 data EncodingError = EncodedStringTooLong
     deriving (Eq, Show)
 
--- | Decode a Bech32 string into a human-readable part and data part.
-decode :: Text -> Either DecodingError (HumanReadablePart, DataPart)
-decode bech32 = do
-
-    guardE (T.length bech32 <= encodedStringMaxLength) StringToDecodeTooLong
+-- | Like 'decode' but does not enforce a maximum length. See also
+-- 'encodeLenient' for details.
+decodeLenient :: Text -> Either DecodingError (HumanReadablePart, DataPart)
+decodeLenient bech32 = do
     guardE (T.length bech32 >= encodedStringMinLength) StringToDecodeTooShort
     guardE (T.map toUpper bech32 == bech32 || T.map toLower bech32 == bech32)
         StringToDecodeHasMixedCase
@@ -331,9 +346,7 @@ decode bech32 = do
         StringToDecodeContainsInvalidChars $ findErrorPositions hrp dcp
     let dp = dataPartFromWords $ take (length dcp - checksumLength) dcp
     return (hrp, dp)
-
   where
-
     -- Use properties of the checksum algorithm to find the locations of errors
     -- within the human-readable part and data-with-checksum part.
     findErrorPositions :: HumanReadablePart -> [Word5] -> [CharPosition]
@@ -349,6 +362,12 @@ decode bech32 = do
             (T.length bech32 - separatorLength - 1 - ) <$>
                 locateErrors (fromIntegral residue) (T.length bech32 - 1)
 
+-- | Decode a Bech32 string into a human-readable part and data part.
+decode :: Text -> Either DecodingError (HumanReadablePart, DataPart)
+decode bech32 = do
+    guardE (T.length bech32 <= encodedStringMaxLength) StringToDecodeTooLong
+    decodeLenient bech32
+
 -- | Parse a data-with-checksum part, checking that each character is part
 -- of the supported character set. If one or more characters are not in the
 -- supported character set, return the list of illegal character positions.

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -33,11 +33,14 @@ library
       -Werror
   build-depends:
       base
+    , base58-bytestring
+    , bech32
     , binary
     , bytestring
     , cardano-wallet-core
-    , servant
+    , cborg
     , memory
+    , servant
     , text
     , text-class
   hs-source-dirs:
@@ -68,10 +71,11 @@ test-suite unit
     , cardano-wallet-core
     , cardano-wallet-jormungandr
     , generic-arbitrary
-    , memory
-    , text-class
     , hspec
+    , memory
     , QuickCheck
+    , text
+    , text-class
   type:
      exitcode-stdio-1.0
   hs-source-dirs:
@@ -81,6 +85,7 @@ test-suite unit
   other-modules:
       Cardano.Wallet.Jormungandr.BinarySpec
       Cardano.Wallet.Jormungandr.EnvironmentSpec
+      Cardano.Wallet.Jormungandr.CompatibilitySpec
       Spec
 
 test-suite integration
@@ -110,4 +115,3 @@ test-suite integration
       Main.hs
   other-modules:
       Cardano.LauncherSpec
-

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs

@@ -25,11 +25,14 @@ module Cardano.Wallet.Jormungandr.Binary
     , LinearFee (..)
     , Milli (..)
 
-     -- * Classes
+      -- * Classes
     , FromBinary (..)
 
 
-     -- * Re-export
+      -- * Legacy Decoders
+    , decodeLegacyAddress
+
+      -- * Re-export
     , runGet
     , Get
 
@@ -73,6 +76,9 @@ import Data.Word
     ( Word16, Word32, Word64, Word8 )
 
 import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Codec.CBOR.Decoding as CBOR
+import qualified Codec.CBOR.Read as CBOR
+import qualified Data.ByteString.Lazy as BL
 
 data BlockHeader = BlockHeader
     { version :: Word16
@@ -401,3 +407,23 @@ instance FromBinary W.Block where
 
 instance FromBinary a => FromBinary [a] where
     get = whileM (not <$> isEmpty) get
+
+{-------------------------------------------------------------------------------
+                              Legacy Decoders
+-------------------------------------------------------------------------------}
+
+-- | Attempt decoding a 'ByteString' into an 'Address'. This merely checks that
+-- the underlying bytestring has a "valid" structure / format without doing much
+-- more.
+decodeLegacyAddress :: ByteString -> Maybe Address
+decodeLegacyAddress bytes =
+    case CBOR.deserialiseFromBytes addressPayloadDecoder (BL.fromStrict bytes) of
+        Right _ -> Just (Address bytes)
+        Left _ -> Nothing
+  where
+    addressPayloadDecoder :: CBOR.Decoder s ()
+    addressPayloadDecoder = ()
+        <$ CBOR.decodeListLenCanonicalOf 2 -- Declare 2-Tuple
+        <* CBOR.decodeTag -- CBOR Tag
+        <* CBOR.decodeBytes -- Payload
+        <* CBOR.decodeWord32 -- CRC

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Compatibility.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 -- |
 -- Copyright: © 2018-2019 IOHK
 -- License: MIT
@@ -14,10 +16,31 @@ module Cardano.Wallet.Jormungandr.Compatibility
 
 import Prelude
 
+import Cardano.Wallet.Jormungandr.Binary
+    ( decodeLegacyAddress )
+import Cardano.Wallet.Jormungandr.Environment
+    ( grouped, hrp, network, single )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( KeyToAddress (..) )
 import Cardano.Wallet.Primitive.Types
-    ( TxId (..) )
+    ( Address (..), DecodeAddress (..), EncodeAddress (..), TxId (..) )
+import Codec.Binary.Bech32
+    ( HumanReadablePart, dataPartFromBytes, dataPartToBytes )
+import Control.Monad
+    ( when )
+import Data.ByteString
+    ( ByteString )
+import Data.ByteString.Base58
+    ( bitcoinAlphabet, decodeBase58, encodeBase58 )
+import Data.Maybe
+    ( isJust )
+import Data.Text.Class
+    ( TextDecodingError (..) )
+
+import qualified Codec.Binary.Bech32 as Bech32
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Text.Encoding as T
 
 -- | A type representing the Jormungandr as a network target. This has an
 -- influence on binary serializer & network primitives. See also 'TxId'
@@ -28,3 +51,89 @@ instance TxId Jormungandr where
 
 instance KeyToAddress Jormungandr where
     keyToAddress = undefined
+
+-- | Encode an 'Address' to a human-readable format. This produces two kinds of
+-- encodings:
+--
+-- - [Base58](https://en.wikipedia.org/wiki/Base58)
+--   for legacy / Byron addresses
+-- - [Bech32](https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki)
+--   for Shelley addresses
+--
+-- The right encoding is picked by looking at the raw 'Address' representation
+-- in order to figure out to which class the address belongs.
+instance EncodeAddress Jormungandr where
+    encodeAddress _ (Address bytes) = do
+        if isJust (decodeLegacyAddress bytes) then base58 else bech32
+      where
+        base58 = T.decodeUtf8 $ encodeBase58 bitcoinAlphabet bytes
+        bech32 = Bech32.encodeLenient hrp (dataPartFromBytes bytes)
+
+-- | Decode text string into an 'Address'. Jörmungandr recognizes two kind of
+-- addresses:
+--
+-- - Legacy / Byron addresses encoded as `Base58`
+-- - Shelley addresses, encoded as `Bech32`
+--
+-- See also 'EncodeAddress Jormungandr'
+instance DecodeAddress Jormungandr where
+    decodeAddress _ x =
+        case (tryBech32, tryBase58) of
+            (Just bytes, _) -> bech32 bytes
+            (_, Just bytes) -> base58 bytes
+            (Nothing, Nothing) -> Left $ TextDecodingError
+                "Unable to decode address: encoding is neither Bech32 nor \
+                \Base58."
+      where
+        -- | Attempt decoding a legacy 'Address' using a Base58 encoding.
+        tryBase58 :: Maybe ByteString
+        tryBase58 = decodeBase58 bitcoinAlphabet (T.encodeUtf8 x)
+
+        -- | Verify the structure of a payload decoded from a Base58 text string
+        base58 :: ByteString -> Either TextDecodingError Address
+        base58 bytes = maybe (Left $ TextDecodingError errByron) Right $
+            decodeLegacyAddress bytes
+          where
+            errByron =
+                "Unable to decode address: neither Bech32-encoded nor a valid \
+                \Byron address."
+
+        -- | Attempt decoding an 'Address' using a Bech32 encoding.
+        tryBech32 :: Maybe (HumanReadablePart, ByteString)
+        tryBech32 = do
+            (hrp', dp) <- either (const Nothing) Just (Bech32.decodeLenient x)
+            (hrp',) <$> dataPartToBytes dp
+
+        -- | Verify the structure of a payload decoded from a Bech32 text string
+        bech32
+            :: (HumanReadablePart, ByteString)
+            -> Either TextDecodingError Address
+        bech32 (hrp', bytes) = do
+            when (hrp /= hrp') $ Left $ TextDecodingError $
+                "This address belongs to another network. Network is: "
+                <> show network <> "."
+            case BS.length bytes of
+                n | n == singleAddressLength ->
+                    when (BS.take 1 bytes /= BS.pack [single]) $
+                        Left (invalidFirstByte single)
+                n | n == groupedAddressLength ->
+                    when (BS.take 1 bytes /= BS.pack [grouped]) $
+                        Left (invalidFirstByte grouped)
+                _ ->
+                    Left $ TextDecodingError $
+                        "Invalid address length (" <> show (BS.length bytes)
+                        <> "): expected either "
+                        <> show singleAddressLength
+                        <> " or "
+                        <> show groupedAddressLength
+                        <> " bytes."
+            return (Address bytes)
+          where
+            singleAddressLength = 33
+            groupedAddressLength = 65
+            invalidFirstByte discriminant = TextDecodingError
+                $ "Invalid address first byte: "
+                <> B8.unpack (BS.take 1 bytes)
+                <> " =/= "
+                <> B8.unpack (BS.pack [discriminant])
+                <> "."