{-# LANGUAGE ScopedTypeVariables #-}

-- | Bech32 Serialisation
--
module Cardano.Api.SerialiseBech32
  ( SerialiseAsBech32(..)
  , serialiseToBech32
  , Bech32DecodeError(..)
  , deserialiseFromBech32
  , deserialiseAnyOfFromBech32
  ) where

import           Data.ByteString (ByteString)
import           Data.Text (Text)

import qualified Data.List as List
import           Data.Set (Set)
import qualified Data.Set as Set

import           Control.Monad (guard)

import qualified Codec.Binary.Bech32 as Bech32

import           Cardano.Api.Error
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.SerialiseRaw
import           Cardano.Api.Utils


class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where

    -- | 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 :: forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 a
a =
    HumanReadablePart -> DataPart -> Text
Bech32.encodeLenient
      HumanReadablePart
humanReadablePart
      (ByteString -> DataPart
Bech32.dataPartFromBytes (forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes a
a))
  where
    humanReadablePart :: HumanReadablePart
humanReadablePart =
      case Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText (forall a. SerialiseAsBech32 a => a -> Text
bech32PrefixFor a
a) of
        Right HumanReadablePart
p  -> HumanReadablePart
p
        Left HumanReadablePartError
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseToBech32: invalid prefix "
                         forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. SerialiseAsBech32 a => a -> Text
bech32PrefixFor a
a)
                         forall a. [a] -> [a] -> [a]
++ [Char]
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show HumanReadablePartError
err


deserialiseFromBech32 :: SerialiseAsBech32 a
                      => AsType a -> Text -> Either Bech32DecodeError a
deserialiseFromBech32 :: forall a.
SerialiseAsBech32 a =>
AsType a -> Text -> Either Bech32DecodeError a
deserialiseFromBech32 AsType a
asType Text
bech32Str = do
    (HumanReadablePart
prefix, DataPart
dataPart) <- Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
bech32Str
                            forall e a e'. Either e a -> (e -> e') -> Either e' a
?!. DecodingError -> Bech32DecodeError
Bech32DecodingError

    let actualPrefix :: Text
actualPrefix      = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix
        permittedPrefixes :: [Text]
permittedPrefixes = forall a. SerialiseAsBech32 a => AsType a -> [Text]
bech32PrefixesPermitted AsType a
asType
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
permittedPrefixes)
      forall a e. Maybe a -> e -> Either e a
?! Text -> Set Text -> Bech32DecodeError
Bech32UnexpectedPrefix Text
actualPrefix (forall a. Ord a => [a] -> Set a
Set.fromList [Text]
permittedPrefixes)

    ByteString
payload <- DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dataPart
                 forall a e. Maybe a -> e -> Either e a
?! Text -> Bech32DecodeError
Bech32DataPartToBytesError (DataPart -> Text
Bech32.dataPartToText DataPart
dataPart)

    a
value <- case forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
asType ByteString
payload of
      Right a
a -> forall a b. b -> Either a b
Right a
a
      Left SerialiseAsRawBytesError
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

    let expectedPrefix :: Text
expectedPrefix = forall a. SerialiseAsBech32 a => a -> Text
bech32PrefixFor a
value
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix forall a. Eq a => a -> a -> Bool
== Text
expectedPrefix)
      forall a e. Maybe a -> e -> Either e a
?! Text -> Text -> Bech32DecodeError
Bech32WrongPrefix Text
actualPrefix Text
expectedPrefix

    forall (m :: * -> *) a. Monad m => a -> m a
return a
value


deserialiseAnyOfFromBech32
  :: forall b.
     [FromSomeType SerialiseAsBech32 b]
  -> Text
  -> Either Bech32DecodeError b
deserialiseAnyOfFromBech32 :: forall b.
[FromSomeType SerialiseAsBech32 b]
-> Text -> Either Bech32DecodeError b
deserialiseAnyOfFromBech32 [FromSomeType SerialiseAsBech32 b]
types Text
bech32Str = do
    (HumanReadablePart
prefix, DataPart
dataPart) <- Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
bech32Str
                            forall e a e'. Either e a -> (e -> e') -> Either e' a
?!. DecodingError -> Bech32DecodeError
Bech32DecodingError

    let actualPrefix :: Text
actualPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix

    FromSomeType AsType a
actualType a -> b
fromType <-
      Text -> Maybe (FromSomeType SerialiseAsBech32 b)
findForPrefix Text
actualPrefix
        forall a e. Maybe a -> e -> Either e a
?! Text -> Set Text -> Bech32DecodeError
Bech32UnexpectedPrefix Text
actualPrefix Set Text
permittedPrefixes

    ByteString
payload <- DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dataPart
                 forall a e. Maybe a -> e -> Either e a
?! Text -> Bech32DecodeError
Bech32DataPartToBytesError (DataPart -> Text
Bech32.dataPartToText DataPart
dataPart)

    a
value <- case forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
actualType ByteString
payload of
      Right a
a -> forall a b. b -> Either a b
Right a
a
      Left SerialiseAsRawBytesError
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

    let expectedPrefix :: Text
expectedPrefix = forall a. SerialiseAsBech32 a => a -> Text
bech32PrefixFor a
value
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix forall a. Eq a => a -> a -> Bool
== Text
expectedPrefix)
      forall a e. Maybe a -> e -> Either e a
?! Text -> Text -> Bech32DecodeError
Bech32WrongPrefix Text
actualPrefix Text
expectedPrefix

    forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
fromType a
value)
  where
    findForPrefix
      :: Text
      -> Maybe (FromSomeType SerialiseAsBech32 b)
    findForPrefix :: Text -> Maybe (FromSomeType SerialiseAsBech32 b)
findForPrefix Text
prefix =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
        (\(FromSomeType AsType a
t a -> b
_) -> Text
prefix forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. SerialiseAsBech32 a => AsType a -> [Text]
bech32PrefixesPermitted AsType a
t)
        [FromSomeType SerialiseAsBech32 b]
types

    permittedPrefixes :: Set Text
    permittedPrefixes :: Set Text
permittedPrefixes =
      forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall a. SerialiseAsBech32 a => AsType a -> [Text]
bech32PrefixesPermitted AsType a
ttoken
        | FromSomeType AsType a
ttoken a -> b
_f <- [FromSomeType SerialiseAsBech32 b]
types
        ]


-- | Bech32 decoding error.
--
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 !(Set Text)

       -- | There was an error in extracting a 'ByteString' from the data part of
       -- the Bech32-encoded string.
     | Bech32DataPartToBytesError !Text

       -- | There was an error in deserialising the bytes into a value of the
       -- expected type.
     | Bech32DeserialiseFromBytesError !ByteString

       -- | 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 (Bech32DecodeError -> Bech32DecodeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bech32DecodeError -> Bech32DecodeError -> Bool
$c/= :: Bech32DecodeError -> Bech32DecodeError -> Bool
== :: Bech32DecodeError -> Bech32DecodeError -> Bool
$c== :: Bech32DecodeError -> Bech32DecodeError -> Bool
Eq, Int -> Bech32DecodeError -> ShowS
[Bech32DecodeError] -> ShowS
Bech32DecodeError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Bech32DecodeError] -> ShowS
$cshowList :: [Bech32DecodeError] -> ShowS
show :: Bech32DecodeError -> [Char]
$cshow :: Bech32DecodeError -> [Char]
showsPrec :: Int -> Bech32DecodeError -> ShowS
$cshowsPrec :: Int -> Bech32DecodeError -> ShowS
Show)

instance Error Bech32DecodeError where
  displayError :: Bech32DecodeError -> [Char]
displayError Bech32DecodeError
err = case Bech32DecodeError
err of
    Bech32DecodingError DecodingError
decErr -> forall a. Show a => a -> [Char]
show DecodingError
decErr -- TODO

    Bech32UnexpectedPrefix Text
actual Set Text
permitted ->
        [Char]
"Unexpected Bech32 prefix: the actual prefix is " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Text
actual
     forall a. Semigroup a => a -> a -> a
<> [Char]
", but it was expected to be "
     forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
" or " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show (forall a. Set a -> [a]
Set.toList Set Text
permitted))

    Bech32DataPartToBytesError Text
_dataPart -> forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"There was an error in extracting the bytes from the data part of the "
      , [Char]
"Bech32-encoded string."
      ]

    Bech32DeserialiseFromBytesError ByteString
_bytes -> forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"There was an error in deserialising the data part of the "
      , [Char]
"Bech32-encoded string into a value of the expected type."
      ]

    Bech32WrongPrefix Text
actual Text
expected -> forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"Mismatch in the Bech32 prefix: the actual prefix is " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Text
actual
      , [Char]
", but the prefix for this payload value should be " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Text
expected
      ]