code review tweaks and other changes to bech32 work

In particular I decided that address serialisation needs its own class
since it is not using one specific format, but the format depends on the
kind of address (base58 vs bech32).

cardano-api/cardano-api.cabal

@@ -47,6 +47,7 @@ library
                       , aeson
                       , attoparsec
                       , base16-bytestring
+                      , base58-bytestring
                       , base64
                       , bech32
                       , bytestring

cardano-api/src/Cardano/Api/Typed.hs

@@ -175,12 +175,15 @@ module Cardano.Api.Typed (
 
     -- ** Bech32
     SerialiseAsBech32,
-    Bech32EncodeError(..),
     Bech32DecodeError(..),
     serialiseToBech32,
     deserialiseFromBech32,
-    renderBech32EncodeError,
-    renderBech32DecodeError,
+
+    -- ** Addresses
+    -- | Address serialisation is (sadly) special
+    SerialiseAddress,
+    serialiseAddress,
+    deserialiseAddress,
 
     -- ** Raw binary
     -- | Some types have a natural raw binary format.
@@ -300,6 +303,7 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Base58 as Base58
 
 import qualified Data.Set as Set
 import qualified Data.Map.Strict as Map
@@ -309,6 +313,7 @@ import qualified Data.Vector as Vector
 
 import qualified Codec.Binary.Bech32 as Bech32
 
+import           Control.Applicative
 import           Control.Monad
 --import Control.Monad.IO.Class
 --import           Control.Monad.Trans.Except
@@ -635,31 +640,62 @@ instance SerialiseAsRawBytes StakeAddress where
 
 
 instance SerialiseAsBech32 (Address Shelley) where
-  humanReadablePrefix (ByronAddress _) =
-    error "TODO"
-  humanReadablePrefix (ShelleyAddress nw _ _) =
-      case Bech32.humanReadablePartFromText prefix of
-        Left err -> error $ "Impossible: " <> show err
-        Right hrp -> hrp
-    where
-      prefix :: Text
-      prefix =
-        case nw of
-          Shelley.Mainnet -> "addr_"
-          Shelley.Testnet -> "addr_test_"
+    bech32PrefixFor (ShelleyAddress Shelley.Mainnet _ _) = "addr"
+    bech32PrefixFor (ShelleyAddress Shelley.Testnet _ _) = "addr_test"
+    bech32PrefixFor (ByronAddress _)                     = "addr_bootstrap"
+
+    bech32PrefixesPermitted AsShelleyAddress = ["addr", "addr_test",
+                                                "addr_bootstrap"]
 
 
 instance SerialiseAsBech32 StakeAddress where
-  humanReadablePrefix (StakeAddress nw _ ) =
-    case Bech32.humanReadablePartFromText prefix of
-      Left err -> error $ "Impossible: " <> show err
-      Right hrp -> hrp
-    where
-      prefix :: Text
-      prefix =
-        case nw of
-          Shelley.Mainnet -> "stake_"
-          Shelley.Testnet -> "stake_test_"
+    bech32PrefixFor (StakeAddress Shelley.Mainnet _) = "stake"
+    bech32PrefixFor (StakeAddress Shelley.Testnet _) = "stake_test"
+
+    bech32PrefixesPermitted AsStakeAddress = ["stake", "stake_test"]
+
+
+instance SerialiseAddress (Address Byron) where
+    serialiseAddress addr@ByronAddress{} =
+         Text.decodeLatin1
+       . Base58.encodeBase58 Base58.bitcoinAlphabet
+       . serialiseToRawBytes
+       $ addr
+
+    deserialiseAddress AsByronAddress txt = do
+      bs <- Base58.decodeBase58 Base58.bitcoinAlphabet (Text.encodeUtf8 txt)
+      deserialiseFromRawBytes AsByronAddress bs
+
+instance SerialiseAddress (Address Shelley) where
+    serialiseAddress (ByronAddress addr) =
+      serialiseAddress (ByronAddress addr :: Address Byron)
+
+    serialiseAddress addr@ShelleyAddress{} =
+      serialiseToBech32 addr
+
+    deserialiseAddress AsShelleyAddress t =
+          deserialiseAsShelleyAddress
+      <|> deserialiseAsByronAddress
+      where
+        deserialiseAsShelleyAddress =
+          either (const Nothing) Just $
+          deserialiseFromBech32 AsShelleyAddress t
+
+        deserialiseAsByronAddress =
+          castByronToShelleyAddress <$>
+          deserialiseAddress AsByronAddress t
+
+        castByronToShelleyAddress :: Address Byron -> Address Shelley
+        castByronToShelleyAddress (ByronAddress addr) = ByronAddress addr
+
+
+instance SerialiseAddress StakeAddress where
+    serialiseAddress addr@StakeAddress{} =
+      serialiseToBech32 addr
+
+    deserialiseAddress AsStakeAddress t =
+      either (const Nothing) Just $
+      deserialiseFromBech32 AsStakeAddress t
 
 
 makeByronAddress :: VerificationKey ByronKey
@@ -2255,104 +2291,122 @@ deserialiseFromRawBytesHex proxy hex =
 --
 
 class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where
-  humanReadablePrefix :: a -> Bech32.HumanReadablePart
-
-  serialiseToBech32 :: a -> Either Bech32EncodeError Text
-  serialiseToBech32 a =
-    first Bech32EncodingError
-      . Bech32.encode (humanReadablePrefix a)
-      . Bech32.dataPartFromBytes
-      . serialiseToRawBytes
-      $ a
-
-  deserialiseFromBech32 :: AsType a -> Text -> Either Bech32DecodeError a
-  deserialiseFromBech32 asType bech32Str =
-      case Bech32.decode bech32Str of
-        Left decErr -> Left (Bech32DecodingError decErr)
-        Right (humanReadablePart, dataPart) ->
-          case deserialiseFromDataPartBytes dataPart tryDeserialise of
-            Left err -> Left err
-            Right res -> validatePrefix humanReadablePart res
-    where
-      deserialiseFromDataPartBytes
-        :: Bech32.DataPart
-        -> (ByteString -> Either Bech32DecodeError b)
-        -> Either Bech32DecodeError b
-      deserialiseFromDataPartBytes dp deserialise =
-        maybe
-          (Left $ Bech32DataPartToBytesError $ Bech32.dataPartToText dp)
-          deserialise
-          (Bech32.dataPartToBytes dp)
-
-      tryDeserialise :: ByteString -> Either Bech32DecodeError a
-      tryDeserialise bs =
-        maybe
-          (Left $ Bech32DeserialiseFromBytesError bs)
-          Right
-          (deserialiseFromRawBytes asType bs)
-
-      validatePrefix
-        :: Bech32.HumanReadablePart
-        -> a
-        -> Either Bech32DecodeError a
-      validatePrefix actualHrp a = do
-        let expected = Bech32.humanReadablePartToText (humanReadablePrefix a)
-            actual = Bech32.humanReadablePartToText actualHrp
-        if expected == actual
-          then Right a
-          else Left (Bech32IncorrectHumanReadablePrefixError expected actual)
-
--- | Bech32 encoding error.
-data Bech32EncodeError
-  = Bech32EncodingError !Bech32.EncodingError
-    -- ^ There was an error encoding the string as Bech32.
-  deriving Show
 
--- | Render a 'Bech32EncodeError' as a human-readable error message.
-renderBech32EncodeError :: Bech32EncodeError -> Text
-renderBech32EncodeError (Bech32EncodingError Bech32.EncodedStringTooLong) =
-  "Failed to encode the Bech32 string as the resulting string would be too long."
+    -- | The human readable prefix to use when encoding this value to Bech32.
+    -- 
+    bech32PrefixFor :: a -> Text
+
+    -- | The set of human readable prefixes that can be used for this type.
+    --
+    bech32PrefixesPermitted :: AsType a -> [Text]
+
+
+serialiseToBech32 :: SerialiseAsBech32 a => a -> Text
+serialiseToBech32 a =
+    Bech32.encodeLenient
+      humanReadablePart
+      (Bech32.dataPartFromBytes (serialiseToRawBytes a))
+  where
+    humanReadablePart =
+      case Bech32.humanReadablePartFromText (bech32PrefixFor a) of
+        Right p  -> p
+        Left err -> error $ "serialiseToBech32: invalid prefix "
+                         ++ show (bech32PrefixFor a)
+                         ++ ", " ++ show err
+
+
+deserialiseFromBech32 :: SerialiseAsBech32 a
+                      => AsType a -> Text -> Either Bech32DecodeError a
+deserialiseFromBech32 asType bech32Str = do
+    (prefix, dataPart) <- Bech32.decodeLenient bech32Str
+                            ?!. Bech32DecodingError
+
+    let actualPrefix      = Bech32.humanReadablePartToText prefix
+        permittedPrefixes = bech32PrefixesPermitted asType
+    guard (actualPrefix `elem` permittedPrefixes)
+      ?! Bech32UnexpectedPrefix actualPrefix permittedPrefixes
+
+    payload <- Bech32.dataPartToBytes dataPart
+                 ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart)
+
+    value <- deserialiseFromRawBytes asType payload
+               ?! Bech32DeserialiseFromBytesError payload
+
+    let expectedPrefix = bech32PrefixFor value
+    guard (actualPrefix == expectedPrefix)
+      ?! Bech32WrongPrefix actualPrefix expectedPrefix
+
+    return value
+
 
 -- | Bech32 decoding error.
-data Bech32DecodeError
-  = Bech32DecodingError !Bech32.DecodingError
-    -- ^ There was an error decoding the string as Bech32.
-  | Bech32IncorrectHumanReadablePrefixError
-    -- ^ The human-readable prefix in the provided Bech32-encoded string
-    -- differs from that which was expected.
-      !Text
-      -- ^ Expected human-readable prefix.
-      !Text
-      -- ^ Actual human-readable prefix.
-  | Bech32DataPartToBytesError
-    -- ^ There was an error in extracting a 'ByteString' from the data part of
-    -- the Bech32-encoded string.
-      !Text
+data Bech32DecodeError =
+
+       -- | There was an error decoding the string as Bech32.
+       Bech32DecodingError Bech32.DecodingError
+
+       -- | The human-readable prefix in the Bech32-encoded string is not one
+       -- of the ones expected.
+     | Bech32UnexpectedPrefix Text [Text]
+
+       -- | There was an error in extracting a 'ByteString' from the data part of
+       -- the Bech32-encoded string.
+     | Bech32DataPartToBytesError
+         Text
       -- ^ The data part from which a 'ByteString' could not be extracted.
-  | Bech32DeserialiseFromBytesError
-    -- ^ There was an error in deserialising the bytes into a value of the
-    -- expected type.
-      !ByteString
-      -- ^ The bytes that could not be deserialised.
+
+      -- ^ There was an error in deserialising the bytes into a value of the
+       -- expected type.
+     | Bech32DeserialiseFromBytesError
+         ByteString
+         -- ^ The bytes that could not be deserialised.
+
+       -- | The human-readable prefix in the Bech32-encoded string does not
+       -- correspond to the prefix that should be used for the payload value.
+     | Bech32WrongPrefix Text Text
+
   deriving Show
 
--- | Render a 'Bech32DecodeError' as a human-readable error message.
-renderBech32DecodeError :: Bech32DecodeError -> Text
-renderBech32DecodeError err =
-  case err of
-    Bech32DecodingError decErr -> Text.pack (show decErr) -- TODO
-    Bech32IncorrectHumanReadablePrefixError expected actual ->
-      "Expected a human-readable prefix of \""
-        <> expected
-        <> "\", but the actual prefix is \""
-        <> actual
-        <> "\"."
+instance Error Bech32DecodeError where
+  displayError err = case err of
+    Bech32DecodingError decErr -> show decErr -- TODO
+
+    Bech32UnexpectedPrefix actual permitted ->
+        "Unexpected Bech32 prefix: the actual prefix is " <> show actual
+     <> ", but it was expected to be "
+     <> intercalate " or " (map show permitted)
+
     Bech32DataPartToBytesError _dataPart ->
-      "There was an error in extracting the bytes from the data part of the \
-      \Bech32-encoded string."
+        "There was an error in extracting the bytes from the data part of the \
+        \Bech32-encoded string."
+
     Bech32DeserialiseFromBytesError _bytes ->
-      "There was an error in deserialising the data part of the \
-      \Bech32-encoded string into a value of the expected type."
+        "There was an error in deserialising the data part of the \
+        \Bech32-encoded string into a value of the expected type."
+
+    Bech32WrongPrefix actual expected ->
+        "Mismatch in the Bech32 prefix: the actual prefix is " <> show actual
+     <> ", but the prefix for this payload value should be " <> show expected
+
+
+
+-- ----------------------------------------------------------------------------
+-- Address Serialisation
+--
+
+-- | Address serialisation uses different serialisation formats for different
+-- kinds of addresses, so it needs its own class.
+--
+-- In particular, Byron addresses are typically formatted in base 58, while
+-- Shelley addresses (payment and stake) are formatted using Bech32.
+--
+class HasTypeProxy addr => SerialiseAddress addr where
+
+    serialiseAddress :: addr -> Text
+
+    deserialiseAddress :: AsType addr -> Text -> Maybe addr
+    -- TODO: consider adding data AddressDecodeError
+
 
 -- ----------------------------------------------------------------------------
 -- TextEnvelope Serialisation
@@ -3142,3 +3196,7 @@ backCompatAlgorithmNameVrf p =
 (?!) :: Maybe a -> e -> Either e a
 Nothing ?! e = Left e
 Just x  ?! _ = Right x
+
+(?!.) :: Either e a -> (e -> e') -> Either e' a
+Left  e ?!. f = Left (f e)
+Right x ?!. _ = Right x

cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs

@@ -32,8 +32,8 @@ import qualified Shelley.Spec.Ledger.TxData as Shelley
 
 import           Cardano.Api hiding (StakePoolMetadata, parseTxIn, parseTxOut, parseWithdrawal)
 import           Cardano.Api.Shelley.OCert (KESPeriod(..))
-import           Cardano.Api.Typed (AsType (..), StakePoolMetadata, StakePoolMetadataReference (..),
-                   StakePoolRelay (..), deserialiseFromBech32, renderBech32DecodeError)
+import           Cardano.Api.Typed (AsType (..), StakePoolMetadata,
+                   StakePoolMetadataReference (..), StakePoolRelay (..))
 import qualified Cardano.Api.Typed as Typed
 import           Cardano.Slotting.Slot (EpochNo (..))
 
@@ -1602,17 +1602,29 @@ parseLovelace = Typed.Lovelace <$> Atto.decimal
 
 parseAddress :: Atto.Parser (Typed.Address Typed.Shelley)
 parseAddress = do
-  str <- Text.decodeLatin1 <$> Atto.takeWhile1 (\c -> c == '_' || Char.isAlphaNum c)
-  case deserialiseFromBech32 AsShelleyAddress str of
-    Left err -> fail . Text.unpack . renderBech32DecodeError $ err
-    Right addr -> pure addr
+    str <- lexPlausibleAddressString
+    case Typed.deserialiseAddress AsShelleyAddress str of
+      Nothing   -> fail "invalid address"
+      Just addr -> pure addr
 
 parseStakeAddress :: Atto.Parser Typed.StakeAddress
 parseStakeAddress = do
-  str <- Text.decodeLatin1 <$> Atto.takeWhile1 (\c -> c == '_' || Char.isAlphaNum c)
-  case deserialiseFromBech32 AsStakeAddress str of
-    Left err -> fail . Text.unpack . renderBech32DecodeError $ err
-    Right addr -> pure addr
+    str <- lexPlausibleAddressString
+    case Typed.deserialiseAddress AsStakeAddress str of
+      Nothing   -> fail "invalid address"
+      Just addr -> pure addr
+
+lexPlausibleAddressString :: Atto.Parser Text
+lexPlausibleAddressString =
+    Text.decodeLatin1 <$> Atto.takeWhile1 isPlausibleAddressChar
+  where
+    -- Covers both base58 and bech32 (with constrained prefixes)
+    isPlausibleAddressChar c =
+         (c >= 'a' && c <= 'z')
+      || (c >= 'A' && c <= 'Z')
+      || (c >= '0' && c <= '9')
+      || c == '_'
+
 
 --------------------------------------------------------------------------------
 -- Helpers