{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Raw binary serialisation
module Cardano.Api.SerialiseRaw
  ( RawBytesHexError (..)
  , SerialiseAsRawBytes (..)
  , SerialiseAsRawBytesError (..)
  , serialiseToRawBytesHex
  , deserialiseFromRawBytesHex
  , serialiseToRawBytesHexText
  )
where

import           Cardano.Api.Error (Error, prettyError)
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.Pretty

import           Data.Bifunctor (Bifunctor (..))
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import           Data.Data (typeRep)
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Typeable (TypeRep, Typeable)

newtype SerialiseAsRawBytesError = SerialiseAsRawBytesError
  -- TODO We can do better than use String to carry the error message
  { SerialiseAsRawBytesError -> String
unSerialiseAsRawBytesError :: String
  }
  deriving (SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool
(SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool)
-> (SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool)
-> Eq SerialiseAsRawBytesError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool
== :: SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool
$c/= :: SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool
/= :: SerialiseAsRawBytesError -> SerialiseAsRawBytesError -> Bool
Eq, Int -> SerialiseAsRawBytesError -> ShowS
[SerialiseAsRawBytesError] -> ShowS
SerialiseAsRawBytesError -> String
(Int -> SerialiseAsRawBytesError -> ShowS)
-> (SerialiseAsRawBytesError -> String)
-> ([SerialiseAsRawBytesError] -> ShowS)
-> Show SerialiseAsRawBytesError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SerialiseAsRawBytesError -> ShowS
showsPrec :: Int -> SerialiseAsRawBytesError -> ShowS
$cshow :: SerialiseAsRawBytesError -> String
show :: SerialiseAsRawBytesError -> String
$cshowList :: [SerialiseAsRawBytesError] -> ShowS
showList :: [SerialiseAsRawBytesError] -> ShowS
Show)

class (HasTypeProxy a, Typeable a) => SerialiseAsRawBytes a where
  serialiseToRawBytes :: a -> ByteString

  deserialiseFromRawBytes :: AsType a -> ByteString -> Either SerialiseAsRawBytesError a

serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex :: forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex = ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

serialiseToRawBytesHexText :: SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText :: forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex

-- | The errors that the pure 'SerialiseAsRawBytes' parsing\/decoding functions can return.
data RawBytesHexError
  = RawBytesHexErrorBase16DecodeFail
      ByteString
      -- ^ original input
      String
      -- ^ error message
  | RawBytesHexErrorRawBytesDecodeFail
      ByteString
      -- ^ original input
      TypeRep
      -- ^ expected type
      SerialiseAsRawBytesError
      -- ^ error message
  deriving Int -> RawBytesHexError -> ShowS
[RawBytesHexError] -> ShowS
RawBytesHexError -> String
(Int -> RawBytesHexError -> ShowS)
-> (RawBytesHexError -> String)
-> ([RawBytesHexError] -> ShowS)
-> Show RawBytesHexError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawBytesHexError -> ShowS
showsPrec :: Int -> RawBytesHexError -> ShowS
$cshow :: RawBytesHexError -> String
show :: RawBytesHexError -> String
$cshowList :: [RawBytesHexError] -> ShowS
showList :: [RawBytesHexError] -> ShowS
Show

instance Error RawBytesHexError where
  prettyError :: forall ann. RawBytesHexError -> Doc ann
prettyError = \case
    RawBytesHexErrorBase16DecodeFail ByteString
input String
message ->
      Doc ann
"Expected Base16-encoded bytestring, but got "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
toText ByteString
input)
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"; "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
message
    RawBytesHexErrorRawBytesDecodeFail ByteString
input TypeRep
asType (SerialiseAsRawBytesError String
e) ->
      Doc ann
"Failed to deserialise " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
toText ByteString
input) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" as " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow TypeRep
asType Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
". " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
e
   where
    toText :: ByteString -> String
toText ByteString
bs = case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
bs of
      Right Text
t -> Text -> String
Text.unpack Text
t
      Left UnicodeException
_ -> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs

deserialiseFromRawBytesHex
  :: SerialiseAsRawBytes a
  => AsType a -> ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex :: forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex AsType a
proxy ByteString
hex = do
  ByteString
raw <- (String -> RawBytesHexError)
-> Either String ByteString -> Either RawBytesHexError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> String -> RawBytesHexError
RawBytesHexErrorBase16DecodeFail ByteString
hex) (Either String ByteString -> Either RawBytesHexError ByteString)
-> Either String ByteString -> Either RawBytesHexError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
Base16.decode ByteString
hex
  case AsType a -> ByteString -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
proxy ByteString
raw of
    Left SerialiseAsRawBytesError
e -> RawBytesHexError -> Either RawBytesHexError a
forall a b. a -> Either a b
Left (RawBytesHexError -> Either RawBytesHexError a)
-> RawBytesHexError -> Either RawBytesHexError a
forall a b. (a -> b) -> a -> b
$ ByteString
-> TypeRep -> SerialiseAsRawBytesError -> RawBytesHexError
RawBytesHexErrorRawBytesDecodeFail ByteString
hex (AsType a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep AsType a
proxy) SerialiseAsRawBytesError
e
    Right a
a -> a -> Either RawBytesHexError a
forall a b. b -> Either a b
Right a
a