{-# LANGUAGE ScopedTypeVariables #-}

-- | Raw binary serialisation
module Cardano.Api.SerialiseUsing
  ( UsingRawBytes (..)
  , UsingRawBytesHex (..)
  , UsingBech32 (..)
  )
where

import           Cardano.Api.Error
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.Pretty
import           Cardano.Api.SerialiseBech32
import           Cardano.Api.SerialiseCBOR
import           Cardano.Api.SerialiseJSON
import           Cardano.Api.SerialiseRaw

import qualified Data.Aeson.Types as Aeson
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BSC
import           Data.String (IsString (..))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Typeable (tyConName, typeRep, typeRepTyCon)

-- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances,
-- based on the 'SerialiseAsRawBytes' instance.
--
-- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah)
newtype UsingRawBytes a = UsingRawBytes a

instance SerialiseAsRawBytes a => ToCBOR (UsingRawBytes a) where
  toCBOR :: UsingRawBytes a -> Encoding
toCBOR (UsingRawBytes a
x) = ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes a
x)

instance SerialiseAsRawBytes a => FromCBOR (UsingRawBytes a) where
  fromCBOR :: forall s. Decoder s (UsingRawBytes a)
fromCBOR = do
    ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
forall a s. FromCBOR a => Decoder s a
fromCBOR
    case AsType a -> ByteString -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
ttoken ByteString
bs of
      Right a
x -> UsingRawBytes a -> Decoder s (UsingRawBytes a)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> UsingRawBytes a
forall a. a -> UsingRawBytes a
UsingRawBytes a
x)
      Left (SerialiseAsRawBytesError [Char]
msg) -> [Char] -> Decoder s (UsingRawBytes a)
forall a. [Char] -> Decoder s a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"cannot deserialise as a " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".  The error was: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg)
   where
    ttoken :: AsType a
ttoken = Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    tname :: [Char]
tname = (TyCon -> [Char]
tyConName (TyCon -> [Char]) -> (Proxy a -> TyCon) -> Proxy a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (Proxy a -> TypeRep) -> Proxy a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep) (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | For use with @deriving via@, to provide instances for any\/all of 'Show',
-- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex
-- encoding, based on the 'SerialiseAsRawBytes' instance.
--
-- > deriving (Show, IsString) via (UsingRawBytesHex Blah)
-- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah)
-- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah)
newtype UsingRawBytesHex a = UsingRawBytesHex a

instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where
  show :: UsingRawBytesHex a -> [Char]
show (UsingRawBytesHex a
x) = ByteString -> [Char]
forall a. Show a => a -> [Char]
show (a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex a
x)

instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where
  fromString :: [Char] -> UsingRawBytesHex a
fromString = ([Char] -> UsingRawBytesHex a)
-> (UsingRawBytesHex a -> UsingRawBytesHex a)
-> Either [Char] (UsingRawBytesHex a)
-> UsingRawBytesHex a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> UsingRawBytesHex a
forall a. HasCallStack => [Char] -> a
error UsingRawBytesHex a -> UsingRawBytesHex a
forall a. a -> a
id (Either [Char] (UsingRawBytesHex a) -> UsingRawBytesHex a)
-> ([Char] -> Either [Char] (UsingRawBytesHex a))
-> [Char]
-> UsingRawBytesHex a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (UsingRawBytesHex a)
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either [Char] (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 (ByteString -> Either [Char] (UsingRawBytesHex a))
-> ([Char] -> ByteString)
-> [Char]
-> Either [Char] (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BSC.pack

instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where
  toJSON :: UsingRawBytesHex a -> Value
toJSON (UsingRawBytesHex a
x) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText a
x)

instance SerialiseAsRawBytes a => FromJSON (UsingRawBytesHex a) where
  parseJSON :: Value -> Parser (UsingRawBytesHex a)
parseJSON =
    [Char]
-> (Text -> Parser (UsingRawBytesHex a))
-> Value
-> Parser (UsingRawBytesHex a)
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
tname ((Text -> Parser (UsingRawBytesHex a))
 -> Value -> Parser (UsingRawBytesHex a))
-> (Text -> Parser (UsingRawBytesHex a))
-> Value
-> Parser (UsingRawBytesHex a)
forall a b. (a -> b) -> a -> b
$
      ([Char] -> Parser (UsingRawBytesHex a))
-> (UsingRawBytesHex a -> Parser (UsingRawBytesHex a))
-> Either [Char] (UsingRawBytesHex a)
-> Parser (UsingRawBytesHex a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Parser (UsingRawBytesHex a)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail UsingRawBytesHex a -> Parser (UsingRawBytesHex a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (UsingRawBytesHex a) -> Parser (UsingRawBytesHex a))
-> (Text -> Either [Char] (UsingRawBytesHex a))
-> Text
-> Parser (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (UsingRawBytesHex a)
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either [Char] (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 (ByteString -> Either [Char] (UsingRawBytesHex a))
-> (Text -> ByteString)
-> Text
-> Either [Char] (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
   where
    tname :: [Char]
tname = (TyCon -> [Char]
tyConName (TyCon -> [Char]) -> (Proxy a -> TyCon) -> Proxy a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (Proxy a -> TypeRep) -> Proxy a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep) (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where
  toJSONKey :: ToJSONKeyFunction (UsingRawBytesHex a)
toJSONKey =
    (UsingRawBytesHex a -> Text)
-> ToJSONKeyFunction (UsingRawBytesHex a)
forall a. (a -> Text) -> ToJSONKeyFunction a
Aeson.toJSONKeyText ((UsingRawBytesHex a -> Text)
 -> ToJSONKeyFunction (UsingRawBytesHex a))
-> (UsingRawBytesHex a -> Text)
-> ToJSONKeyFunction (UsingRawBytesHex a)
forall a b. (a -> b) -> a -> b
$ \(UsingRawBytesHex a
x) -> a -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText a
x

instance SerialiseAsRawBytes a => FromJSONKey (UsingRawBytesHex a) where
  fromJSONKey :: FromJSONKeyFunction (UsingRawBytesHex a)
fromJSONKey =
    (Text -> Parser (UsingRawBytesHex a))
-> FromJSONKeyFunction (UsingRawBytesHex a)
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
Aeson.FromJSONKeyTextParser ((Text -> Parser (UsingRawBytesHex a))
 -> FromJSONKeyFunction (UsingRawBytesHex a))
-> (Text -> Parser (UsingRawBytesHex a))
-> FromJSONKeyFunction (UsingRawBytesHex a)
forall a b. (a -> b) -> a -> b
$
      ([Char] -> Parser (UsingRawBytesHex a))
-> (UsingRawBytesHex a -> Parser (UsingRawBytesHex a))
-> Either [Char] (UsingRawBytesHex a)
-> Parser (UsingRawBytesHex a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Parser (UsingRawBytesHex a)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail UsingRawBytesHex a -> Parser (UsingRawBytesHex a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (UsingRawBytesHex a) -> Parser (UsingRawBytesHex a))
-> (Text -> Either [Char] (UsingRawBytesHex a))
-> Text
-> Parser (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (UsingRawBytesHex a)
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either [Char] (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 (ByteString -> Either [Char] (UsingRawBytesHex a))
-> (Text -> ByteString)
-> Text
-> Either [Char] (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8

deserialiseFromRawBytesBase16
  :: SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 :: forall a.
SerialiseAsRawBytes a =>
ByteString -> Either [Char] (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 ByteString
str =
  case ByteString -> Either [Char] ByteString
Base16.decode ByteString
str of
    Right ByteString
raw -> case AsType a -> ByteString -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
ttoken ByteString
raw of
      Right a
x -> UsingRawBytesHex a -> Either [Char] (UsingRawBytesHex a)
forall a b. b -> Either a b
Right (a -> UsingRawBytesHex a
forall a. a -> UsingRawBytesHex a
UsingRawBytesHex a
x)
      Left (SerialiseAsRawBytesError [Char]
msg) -> [Char] -> Either [Char] (UsingRawBytesHex a)
forall a b. a -> Either a b
Left ([Char]
"cannot deserialise " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".  The error was: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg)
    Left [Char]
msg -> [Char] -> Either [Char] (UsingRawBytesHex a)
forall a b. a -> Either a b
Left ([Char]
"invalid hex " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg)
 where
  ttoken :: AsType a
ttoken = Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {a}. Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | For use with @deriving via@, to provide instances for any\/all of 'Show',
-- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a bech32
-- encoding, based on the 'SerialiseAsBech32' instance.
--
-- > deriving (Show, IsString) via (UsingBech32 Blah)
-- > deriving (ToJSON, FromJSON) via (UsingBech32 Blah)
-- > deriving (ToJSONKey, FromJSONKey) via (UsingBech32 Blah)
newtype UsingBech32 a = UsingBech32 a

instance SerialiseAsBech32 a => Show (UsingBech32 a) where
  show :: UsingBech32 a -> [Char]
show (UsingBech32 a
x) = Text -> [Char]
forall a. Show a => a -> [Char]
show (a -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 a
x)

instance SerialiseAsBech32 a => IsString (UsingBech32 a) where
  fromString :: [Char] -> UsingBech32 a
fromString [Char]
str =
    case AsType a -> Text -> Either Bech32DecodeError a
forall a.
SerialiseAsBech32 a =>
AsType a -> Text -> Either Bech32DecodeError a
deserialiseFromBech32 AsType a
ttoken ([Char] -> Text
Text.pack [Char]
str) of
      Right a
x -> a -> UsingBech32 a
forall a. a -> UsingBech32 a
UsingBech32 a
x
      Left Bech32DecodeError
e ->
        [Char] -> UsingBech32 a
forall a. HasCallStack => [Char] -> a
error ([Char] -> UsingBech32 a) -> [Char] -> UsingBech32 a
forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> [Char]
docToString (Doc AnsiStyle -> [Char]) -> Doc AnsiStyle -> [Char]
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle
"fromString: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
str Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Bech32DecodeError -> Doc AnsiStyle
forall e ann. Error e => e -> Doc ann
forall ann. Bech32DecodeError -> Doc ann
prettyError Bech32DecodeError
e
   where
    ttoken :: AsType a
    ttoken :: AsType a
ttoken = Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType Proxy a
forall {k} (t :: k). Proxy t
Proxy

instance SerialiseAsBech32 a => ToJSON (UsingBech32 a) where
  toJSON :: UsingBech32 a -> Value
toJSON (UsingBech32 a
x) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 a
x)

instance SerialiseAsBech32 a => FromJSON (UsingBech32 a) where
  parseJSON :: Value -> Parser (UsingBech32 a)
parseJSON =
    [Char]
-> (Text -> Parser (UsingBech32 a))
-> Value
-> Parser (UsingBech32 a)
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
tname ((Text -> Parser (UsingBech32 a))
 -> Value -> Parser (UsingBech32 a))
-> (Text -> Parser (UsingBech32 a))
-> Value
-> Parser (UsingBech32 a)
forall a b. (a -> b) -> a -> b
$ \Text
str ->
      case AsType a -> Text -> Either Bech32DecodeError a
forall a.
SerialiseAsBech32 a =>
AsType a -> Text -> Either Bech32DecodeError a
deserialiseFromBech32 AsType a
ttoken Text
str of
        Right a
x -> UsingBech32 a -> Parser (UsingBech32 a)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> UsingBech32 a
forall a. a -> UsingBech32 a
UsingBech32 a
x)
        Left Bech32DecodeError
e -> [Char] -> Parser (UsingBech32 a)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser (UsingBech32 a))
-> [Char] -> Parser (UsingBech32 a)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> [Char]
docToString (Doc AnsiStyle -> [Char]) -> Doc AnsiStyle -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
str Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Bech32DecodeError -> Doc AnsiStyle
forall e ann. Error e => e -> Doc ann
forall ann. Bech32DecodeError -> Doc ann
prettyError Bech32DecodeError
e
   where
    ttoken :: AsType a
ttoken = Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    tname :: [Char]
tname = (TyCon -> [Char]
tyConName (TyCon -> [Char]) -> (Proxy a -> TyCon) -> Proxy a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (Proxy a -> TypeRep) -> Proxy a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep) (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance SerialiseAsBech32 a => ToJSONKey (UsingBech32 a)

instance SerialiseAsBech32 a => FromJSONKey (UsingBech32 a)