WIP

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

@@ -175,8 +175,12 @@ module Cardano.Api.Typed (
 
     -- ** Bech32
     SerialiseAsBech32,
+    Bech32EncodeError(..),
+    Bech32DecodeError(..),
     serialiseToBech32,
     deserialiseFromBech32,
+    renderBech32EncodeError,
+    renderBech32DecodeError,
 
     -- ** Raw binary
     -- | Some types have a natural raw binary format.
@@ -303,7 +307,6 @@ import           Data.Map.Strict (Map)
 import qualified Data.Sequence.Strict as Seq
 import qualified Data.Vector as Vector
 
--- TODO @intricate: Where to put this?
 import qualified Codec.Binary.Bech32 as Bech32
 
 import           Control.Monad
@@ -631,23 +634,16 @@ instance SerialiseAsRawBytes StakeAddress where
           Just (Shelley.RewardAcnt nw sc) -> Just (StakeAddress nw sc)
 
 
-instance SerialiseAsBech32 (Address Byron) where
-  humanReadablePrefix _ =
-    case Bech32.humanReadablePartFromText "ca" of
-      Left err -> error $ "Impossible: " <> show err
-      Right prefix -> prefix
-
-
 instance SerialiseAsBech32 (Address Shelley) where
   humanReadablePrefix _ =
-    case Bech32.humanReadablePartFromText "ca" of
+    case Bech32.humanReadablePartFromText "addr_" of
       Left err -> error $ "Impossible: " <> show err
       Right prefix -> prefix
 
 
 instance SerialiseAsBech32 StakeAddress where
   humanReadablePrefix _ =
-    case Bech32.humanReadablePartFromText "ca" of
+    case Bech32.humanReadablePartFromText "stake_" of
       Left err -> error $ "Impossible: " <> show err
       Right prefix -> prefix
 
@@ -2249,23 +2245,92 @@ deserialiseFromRawBytesHex proxy hex =
 class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where
   humanReadablePrefix :: AsType a -> Bech32.HumanReadablePart
 
-  serialiseToBech32 :: a -> Either Bech32.EncodingError Text
+  serialiseToBech32 :: a -> Either Bech32EncodeError Text
   serialiseToBech32 =
-    Bech32.encode (humanReadablePrefix (proxyToAsType Proxy :: AsType a))
+    first Bech32EncodingError
+      . Bech32.encode (humanReadablePrefix (proxyToAsType Proxy :: AsType a))
       . Bech32.dataPartFromBytes
       . serialiseToRawBytes
 
-  -- TODO @intricate: Should we confirm the human-readable prefix?
-  --                  It seems we should.
-  -- TODO @intricate: Get rid of the 'Maybe' result and use an error type once
-  --                  you understand what can cause the 'Nothing' case.
-  deserialiseFromBech32 :: AsType a -> Text -> Either Bech32.DecodingError (Maybe a)
+  deserialiseFromBech32 :: AsType a -> Text -> Either Bech32DecodeError a
   deserialiseFromBech32 asType bech32Str =
-    case Bech32.decode bech32Str of
-      Left decErr -> Left decErr
-      Right (_humanReadablePart, dataPart) ->
-        -- TODO @intricate: This is ugly. Fix it.
-        Right (deserialiseFromRawBytes asType =<< Bech32.dataPartToBytes dataPart)
+      case Bech32.decode bech32Str of
+        Left decErr -> Left (Bech32DecodingError decErr)
+        Right (humanReadablePart, dataPart) -> do
+          let expected = Bech32.humanReadablePartToText (humanReadablePrefix asType)
+              actual = Bech32.humanReadablePartToText humanReadablePart
+          if expected == actual
+            then withDataPartAsBytes dataPart eitherDeserialiseRawBytes
+            else Left (Bech32IncorrectHumanReadablePrefixError expected actual)
+    where
+      withDataPartAsBytes
+        :: Bech32.DataPart
+        -> (ByteString -> Either Bech32DecodeError b)
+        -> Either Bech32DecodeError b
+      withDataPartAsBytes dp f =
+        maybe
+          (Left $ Bech32DataPartToBytesError $ Bech32.dataPartToText dp)
+          f
+          (Bech32.dataPartToBytes dp)
+
+      eitherDeserialiseRawBytes :: ByteString -> Either Bech32DecodeError a
+      eitherDeserialiseRawBytes bs =
+        maybe
+          (Left $ Bech32DeserialiseFromBytesError bs)
+          Right
+          (deserialiseFromRawBytes asType bs)
+
+-- | 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."
+
+-- | 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
+      -- ^ 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.
+  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
+        <> "\"."
+    Bech32DataPartToBytesError _dataPart ->
+      "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."
 
 -- ----------------------------------------------------------------------------
 -- TextEnvelope Serialisation

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 (StakePoolMetadata, StakePoolMetadataReference (..),
-                   StakePoolRelay (..))
+import           Cardano.Api.Typed (AsType (..), StakePoolMetadata, StakePoolMetadataReference (..),
+                   StakePoolRelay (..), deserialiseFromBech32, renderBech32DecodeError)
 import qualified Cardano.Api.Typed as Typed
 import           Cardano.Slotting.Slot (EpochNo (..))
 
@@ -1070,10 +1070,16 @@ pTxOut =
 
     parseAddress :: Atto.Parser (Typed.Address Typed.Shelley)
     parseAddress = do
-      bstr <- Atto.takeWhile1 Char.isHexDigit
-      case Typed.deserialiseFromRawBytesHex Typed.AsShelleyAddress bstr of
-        Just addr -> return addr
-        Nothing -> fail $ "Incorrect address format: " ++ show bstr
+      str <- Text.decodeLatin1 <$> Atto.takeWhile1 Char.isAlphaNum
+      case deserialiseFromBech32 AsShelleyAddress str of
+        Left err -> fail . Text.unpack . renderBech32DecodeError $ err
+        Right addr -> pure addr
+
+      -- TODO @intricate: Should we continue to support hex-encoded addresses?
+      -- bstr <- Atto.takeWhile1 Char.isHexDigit
+      -- case Typed.deserialiseFromRawBytesHex Typed.AsShelleyAddress bstr of
+      --   Just addr -> return addr
+      --   Nothing -> fail $ "Incorrect address format: " ++ show bstr
 
 pTxTTL :: Parser SlotNo
 pTxTTL =

cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs

@@ -9,19 +9,23 @@ import           Prelude (putStrLn)
 
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
 
 import           Control.Monad.Trans.Except (ExceptT)
-import           Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT)
+import           Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither,
+                   newExceptT)
 
 import           Cardano.Api
 import           Cardano.Api.TextView (TextViewTitle (..))
 import qualified Cardano.Api.Typed as Api (NetworkId (..))
-import           Cardano.Api.Typed (AsType (..), Error (..), FileError,
-                   Key (..), PaymentCredential (..), StakeCredential (..),
-                   StakeAddressReference (..), StakeKey, TextEnvelopeError,
-                   VerificationKey, generateSigningKey, getVerificationKey,
-                   makeShelleyAddress, readFileTextEnvelope,
-                   serialiseToRawBytesHex, writeFileTextEnvelope)
+import           Cardano.Api.Typed (AsType (..), Bech32EncodeError,
+                   Error (..), FileError, Key (..), PaymentCredential (..),
+                   StakeCredential (..), StakeAddressReference (..), StakeKey,
+                   TextEnvelopeError, VerificationKey, generateSigningKey,
+                   getVerificationKey, makeShelleyAddress,
+                   readFileTextEnvelope, renderBech32EncodeError,
+                   serialiseToBech32, serialiseToRawBytesHex,
+                   writeFileTextEnvelope)
 
 import           Cardano.CLI.Shelley.Parsers
                    (OutputFile (..), SigningKeyFile (..), VerificationKeyFile (..),
@@ -31,6 +35,7 @@ import           Cardano.CLI.Shelley.Run.Address.Info (ShelleyAddressInfoError,
 
 data ShelleyAddressCmdError
   = ShelleyAddressCmdAddressInfoError !ShelleyAddressInfoError
+  | ShelleyAddressCmdBech32EncodeError !Bech32EncodeError
   | ShelleyAddressCmdReadFileError !(FileError TextEnvelopeError)
   | ShelleyAddressCmdWriteFileError !(FileError ())
   deriving Show
@@ -40,6 +45,7 @@ renderShelleyAddressCmdError err =
   case err of
     ShelleyAddressCmdAddressInfoError addrInfoErr ->
       "Error occurred while printing address info: " <> renderShelleyAddressInfoError addrInfoErr
+    ShelleyAddressCmdBech32EncodeError encErr -> renderBech32EncodeError encErr
     ShelleyAddressCmdReadFileError fileErr -> Text.pack (displayError fileErr)
     ShelleyAddressCmdWriteFileError fileErr -> Text.pack (displayError fileErr)
 
@@ -98,11 +104,14 @@ runAddressBuild (VerificationKeyFile payVkeyFp) mstkVkeyFp nw mOutFp = do
         Nothing -> pure NoStakeAddress
 
     let addr = makeShelleyAddress nwId paymentCred stakeAddrRef
-        hexAddr = serialiseToRawBytesHex addr
+
+    bech32Addr <- firstExceptT ShelleyAddressCmdBech32EncodeError
+      . hoistEither
+      $ serialiseToBech32 addr
 
     case mOutFp of
-      Just (OutputFile fpath) -> liftIO . BS.writeFile fpath $ hexAddr
-      Nothing -> liftIO $ BS.putStrLn hexAddr
+      Just (OutputFile fpath) -> liftIO . Text.writeFile fpath $ bech32Addr
+      Nothing -> liftIO $ Text.putStrLn bech32Addr
   where
     toStakeAddrRef :: VerificationKey StakeKey -> StakeAddressReference
     toStakeAddrRef = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash

cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs

@@ -7,8 +7,8 @@ module Cardano.CLI.Shelley.Run.StakeAddress
 
 import           Cardano.Prelude
 
-import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
 
 import           Control.Monad.Trans.Except (ExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, left, newExceptT)
@@ -18,14 +18,14 @@ import           Cardano.Api (ApiError, Network (..), SigningKey (..),
                    writeSigningKey, writeStakingVerificationKey)
 import           Cardano.Api.TextView (TextViewTitle (..), textShow)
 import qualified Cardano.Api.Typed as Api (NetworkId (..))
-import           Cardano.Api.Typed (AsType (..), Error (..), FileError,
-                   Key (..), StakeCredential (..), TextEnvelopeError,
-                   generateSigningKey, getVerificationKey, makeStakeAddress,
-                   makeStakeAddressDelegationCertificate,
+import           Cardano.Api.Typed (AsType (..), Bech32EncodeError,
+                   Error (..), FileError, Key (..), StakeCredential (..),
+                   TextEnvelopeError, generateSigningKey, getVerificationKey,
+                   makeStakeAddress, makeStakeAddressDelegationCertificate,
                    makeStakeAddressDeregistrationCertificate,
                    makeStakeAddressRegistrationCertificate,
-                   readFileTextEnvelope, serialiseToRawBytesHex,
-                   writeFileTextEnvelope)
+                   readFileTextEnvelope, renderBech32EncodeError,
+                   serialiseToBech32, writeFileTextEnvelope)
 
 import qualified Cardano.Crypto.DSIGN as DSIGN
 
@@ -43,6 +43,7 @@ data ShelleyStakeAddressCmdError
       -- ^ bech32 public key
   | ShelleyStakeAddressWriteSignKeyError !FilePath !ApiError
   | ShelleyStakeAddressWriteVerKeyError !FilePath !ApiError
+  | ShelleyStakeAddressBech32EncodeError !Bech32EncodeError
   | ShelleyStakeAddressReadFileError !(FileError TextEnvelopeError)
   | ShelleyStakeAddressWriteFileError !(FileError ())
   deriving Show
@@ -58,6 +59,7 @@ renderShelleyStakeAddressCmdError err =
     ShelleyStakeAddressKeyPairError bech32PrivKey bech32PubKey ->
       "Error while deriving the shelley verification key from bech32 private Key: " <> bech32PrivKey <>
       " Corresponding bech32 public key: " <> bech32PubKey
+    ShelleyStakeAddressBech32EncodeError encErr -> renderBech32EncodeError encErr
     ShelleyStakeAddressReadFileError fileErr -> Text.pack (displayError fileErr)
     ShelleyStakeAddressWriteFileError fileErr -> Text.pack (displayError fileErr)
 
@@ -103,11 +105,14 @@ runStakeAddressBuild (VerificationKeyFile stkVkeyFp) network mOutputFp = do
 
     let stakeCred = StakeCredentialByKey (verificationKeyHash stakeVerKey)
         rwdAddr = makeStakeAddress nwId stakeCred
-        hexAddr = LBS.fromStrict (serialiseToRawBytesHex rwdAddr)
+
+    bech32Addr <- firstExceptT ShelleyStakeAddressBech32EncodeError
+      . hoistEither
+      $ serialiseToBech32 rwdAddr
 
     case mOutputFp of
-      Just (OutputFile fpath) -> liftIO $ LBS.writeFile fpath hexAddr
-      Nothing -> liftIO $ LBS.putStrLn hexAddr
+      Just (OutputFile fpath) -> liftIO $ Text.writeFile fpath bech32Addr
+      Nothing -> liftIO $ Text.putStrLn bech32Addr
   where
     -- TODO: Remove this once we remove usage of 'Cardano.Api.Types.Network'
     --       from this module.