{-# LANGUAGE ScopedTypeVariables #-}

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

import Cardano.Api.Error
import Cardano.Api.HasTypeProxy
import Cardano.Api.Pretty
import Cardano.Api.Serialise.Bech32
import Cardano.Api.Serialise.Cbor
import Cardano.Api.Serialise.Json
import Cardano.Api.Serialise.Raw

import Data.Aeson.Types qualified as Aeson
import Data.ByteString qualified as B
import Data.Text.Encoding qualified as Text
import Data.Typeable (tyConName, typeRep, typeRepTyCon)
import Numeric (showBin)

-- | 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
    bs <- Decoder s ByteString
forall s. Decoder s ByteString
forall a s. FromCBOR a => Decoder s a
fromCBOR
    case deserialiseFromRawBytes ttoken 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)

-- | Prints the representation in binary format, quoted
instance SerialiseAsRawBytes a => Show (UsingRawBytes a) where
  showsPrec :: Int -> UsingRawBytes a -> [Char] -> [Char]
showsPrec Int
_ (UsingRawBytes a
x) = Char -> [Char] -> [Char]
showChar Char
'"' ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char] -> [Char]] -> [Char] -> [Char]
forall a. Monoid a => [a] -> a
mconcat ((Word8 -> [Char] -> [Char]) -> [Word8] -> [[Char] -> [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showBin ([Word8] -> [[Char] -> [Char]])
-> (ByteString -> [Word8]) -> ByteString -> [[Char] -> [Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack (ByteString -> [[Char] -> [Char]])
-> ByteString -> [[Char] -> [Char]]
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes a
x) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char] -> [Char]
showChar Char
'"'

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

-- | Quotes the representation
instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where
  show :: UsingRawBytesHex a -> [Char]
show (UsingRawBytesHex a
x) = ByteString -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex a
x

instance SerialiseAsRawBytes a => Pretty (UsingRawBytesHex a) where
  pretty :: forall ann. UsingRawBytesHex a -> Doc ann
pretty (UsingRawBytesHex a
a) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText a
a

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 =
    (Parser a -> Parser (UsingRawBytesHex a))
-> (Value -> Parser a) -> Value -> Parser (UsingRawBytesHex a)
forall a b. (a -> b) -> (Value -> a) -> Value -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> UsingRawBytesHex a)
-> Parser a -> Parser (UsingRawBytesHex a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> UsingRawBytesHex a
forall a. a -> UsingRawBytesHex a
UsingRawBytesHex) ((Value -> Parser a) -> Value -> Parser (UsingRawBytesHex a))
-> ((Text -> Parser a) -> Value -> Parser a)
-> (Text -> Parser a)
-> Value
-> Parser (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Text -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
tname ((Text -> Parser a) -> Value -> Parser (UsingRawBytesHex a))
-> (Text -> Parser a) -> Value -> Parser (UsingRawBytesHex a)
forall a b. (a -> b) -> a -> b
$
      Either RawBytesHexError a -> Parser a
forall (m :: * -> *) e a.
(MonadFail m, Error e) =>
Either e a -> m a
failEitherError (Either RawBytesHexError a -> Parser a)
-> (Text -> Either RawBytesHexError a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either RawBytesHexError a
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex (ByteString -> Either RawBytesHexError a)
-> (Text -> ByteString) -> Text -> Either RawBytesHexError 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 =
    (a -> UsingRawBytesHex a)
-> FromJSONKeyFunction a
-> FromJSONKeyFunction (UsingRawBytesHex a)
forall a b.
(a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> UsingRawBytesHex a
forall a. a -> UsingRawBytesHex a
UsingRawBytesHex (FromJSONKeyFunction a -> FromJSONKeyFunction (UsingRawBytesHex a))
-> ((Text -> Parser a) -> FromJSONKeyFunction a)
-> (Text -> Parser a)
-> FromJSONKeyFunction (UsingRawBytesHex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Parser a) -> FromJSONKeyFunction a
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
Aeson.FromJSONKeyTextParser ((Text -> Parser a) -> FromJSONKeyFunction (UsingRawBytesHex a))
-> (Text -> Parser a) -> FromJSONKeyFunction (UsingRawBytesHex a)
forall a b. (a -> b) -> a -> b
$
      Either RawBytesHexError a -> Parser a
forall (m :: * -> *) e a.
(MonadFail m, Error e) =>
Either e a -> m a
failEitherError (Either RawBytesHexError a -> Parser a)
-> (Text -> Either RawBytesHexError a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either RawBytesHexError a
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex (ByteString -> Either RawBytesHexError a)
-> (Text -> ByteString) -> Text -> Either RawBytesHexError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8

-- | 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, Pretty) via (UsingBech32 Blah)
-- > deriving (ToJSON, FromJSON) via (UsingBech32 Blah)
-- > deriving (ToJSONKey, FromJSONKey) via (UsingBech32 Blah)
newtype UsingBech32 a = UsingBech32 a

-- | Quotes the representation
instance SerialiseAsBech32 a => Show (UsingBech32 a) where
  show :: UsingBech32 a -> [Char]
show (UsingBech32 a
x) = Text -> [Char]
forall a. Show a => a -> [Char]
show (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 a
x

instance SerialiseAsBech32 a => Pretty (UsingBech32 a) where
  pretty :: forall ann. UsingBech32 a -> Doc ann
pretty (UsingBech32 a
a) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 a
a

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 Text -> Either Bech32DecodeError a
forall a. SerialiseAsBech32 a => Text -> Either Bech32DecodeError a
deserialiseFromBech32 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
    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)