{-# LANGUAGE ScopedTypeVariables #-}

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

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

import Data.Aeson.Types qualified as Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Char8 qualified as BSC
import Data.String (IsString (..))
import Data.Text qualified as Text
import Data.Text.Encoding qualified 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)