{-# LANGUAGE ScopedTypeVariables #-}

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

import           Prelude

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

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


deserialiseFromBech32 :: SerialiseAsBech32 a
                      => AsType a -> Text -> Either Bech32DecodeError a
deserialiseFromBech32 :: 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
                            Either DecodingError (HumanReadablePart, DataPart)
-> (DecodingError -> Bech32DecodeError)
-> Either Bech32DecodeError (HumanReadablePart, DataPart)
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 = AsType a -> [Text]
forall a. SerialiseAsBech32 a => AsType a -> [Text]
bech32PrefixesPermitted AsType a
asType
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
permittedPrefixes)
      Maybe () -> Bech32DecodeError -> Either Bech32DecodeError ()
forall a e. Maybe a -> e -> Either e a
?! Text -> Set Text -> Bech32DecodeError
Bech32UnexpectedPrefix Text
actualPrefix ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
permittedPrefixes)

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

    a
value <- AsType a -> ByteString -> Maybe a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
deserialiseFromRawBytes AsType a
asType ByteString
payload
               Maybe a -> Bech32DecodeError -> Either Bech32DecodeError a
forall a e. Maybe a -> e -> Either e a
?! ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

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

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


deserialiseAnyOfFromBech32
  :: forall b.
     [FromSomeType SerialiseAsBech32 b]
  -> Text
  -> Either Bech32DecodeError b
deserialiseAnyOfFromBech32 :: [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
                            Either DecodingError (HumanReadablePart, DataPart)
-> (DecodingError -> Bech32DecodeError)
-> Either Bech32DecodeError (HumanReadablePart, DataPart)
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
        Maybe (FromSomeType SerialiseAsBech32 b)
-> Bech32DecodeError
-> Either Bech32DecodeError (FromSomeType SerialiseAsBech32 b)
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
                 Maybe ByteString
-> Bech32DecodeError -> Either Bech32DecodeError ByteString
forall a e. Maybe a -> e -> Either e a
?! Text -> Bech32DecodeError
Bech32DataPartToBytesError (DataPart -> Text
Bech32.dataPartToText DataPart
dataPart)

    a
value <- AsType a -> ByteString -> Maybe a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
deserialiseFromRawBytes AsType a
actualType ByteString
payload
               Maybe a -> Bech32DecodeError -> Either Bech32DecodeError a
forall a e. Maybe a -> e -> Either e a
?! ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

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

    b -> Either Bech32DecodeError b
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 =
      (FromSomeType SerialiseAsBech32 b -> Bool)
-> [FromSomeType SerialiseAsBech32 b]
-> Maybe (FromSomeType SerialiseAsBech32 b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
        (\(FromSomeType AsType a
t a -> b
_) -> Text
prefix Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` AsType a -> [Text]
forall a. SerialiseAsBech32 a => AsType a -> [Text]
bech32PrefixesPermitted AsType a
t)
        [FromSomeType SerialiseAsBech32 b]
types

    permittedPrefixes :: Set Text
    permittedPrefixes :: Set Text
permittedPrefixes =
      [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ AsType a -> [Text]
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
(Bech32DecodeError -> Bech32DecodeError -> Bool)
-> (Bech32DecodeError -> Bech32DecodeError -> Bool)
-> Eq Bech32DecodeError
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 -> [Char] -> [Char]
[Bech32DecodeError] -> [Char] -> [Char]
Bech32DecodeError -> [Char]
(Int -> Bech32DecodeError -> [Char] -> [Char])
-> (Bech32DecodeError -> [Char])
-> ([Bech32DecodeError] -> [Char] -> [Char])
-> Show Bech32DecodeError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Bech32DecodeError] -> [Char] -> [Char]
$cshowList :: [Bech32DecodeError] -> [Char] -> [Char]
show :: Bech32DecodeError -> [Char]
$cshow :: Bech32DecodeError -> [Char]
showsPrec :: Int -> Bech32DecodeError -> [Char] -> [Char]
$cshowsPrec :: Int -> Bech32DecodeError -> [Char] -> [Char]
Show)

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

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

    Bech32DataPartToBytesError Text
_dataPart ->
        [Char]
"There was an error in extracting the bytes from the data part of the \
        \Bech32-encoded string."

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

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