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

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

import Cardano.Api.Error (Error, failEitherError, prettyError)
import Cardano.Api.HasTypeProxy
import Cardano.Api.Monad.Error (MonadError (..))
import Cardano.Api.Parser.Text qualified as P
import Cardano.Api.Pretty

import Data.Bifunctor (Bifunctor (..))
import Data.Bits (Bits (..))
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Char8 as BSC
import Data.Data (typeRep)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Typeable (TypeRep, Typeable)
import Data.Word (Word16, Word8)

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

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

instance SerialiseAsRawBytes Word8 where
  serialiseToRawBytes :: Word8 -> ByteString
serialiseToRawBytes = Word8 -> ByteString
BS.singleton
  deserialiseFromRawBytes :: AsType Word8 -> ByteString -> Either SerialiseAsRawBytesError Word8
deserialiseFromRawBytes AsType Word8
R:AsTypeWord8
AsWord8 ByteString
bs = case ByteString -> [Word8]
BS.unpack ByteString
bs of
    [Word8
w] -> Word8 -> Either SerialiseAsRawBytesError Word8
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word8
w
    [Word8]
_ ->
      SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError Word8
forall a.
SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError Word8)
-> (String -> SerialiseAsRawBytesError)
-> String
-> Either SerialiseAsRawBytesError Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError (String -> Either SerialiseAsRawBytesError Word8)
-> String -> Either SerialiseAsRawBytesError Word8
forall a b. (a -> b) -> a -> b
$
        String
"Cannot decode Word8 from (hex): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSC.unpack (ByteString -> ByteString
Base16.encode ByteString
bs)

instance SerialiseAsRawBytes Word16 where
  serialiseToRawBytes :: Word16 -> ByteString
serialiseToRawBytes = LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Word16 -> LazyByteString) -> Word16 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BSB.toLazyByteString (Builder -> LazyByteString)
-> (Word16 -> Builder) -> Word16 -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
BSB.word16BE
  deserialiseFromRawBytes :: AsType Word16
-> ByteString -> Either SerialiseAsRawBytesError Word16
deserialiseFromRawBytes AsType Word16
R:AsTypeWord16
AsWord16 ByteString
bs = case Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16) -> [Word8] -> [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Word8]
BS.unpack ByteString
bs of
    [] -> SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError Word16
forall a.
SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SerialiseAsRawBytesError
 -> Either SerialiseAsRawBytesError Word16)
-> SerialiseAsRawBytesError
-> Either SerialiseAsRawBytesError Word16
forall a b. (a -> b) -> a -> b
$ String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError String
"Cannot deserialise empty bytes into Word16"
    [Word16
b0] -> Word16 -> Either SerialiseAsRawBytesError Word16
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
b0 -- just return the single byte present
    [Word16
b0, Word16
b1] ->
      -- we have number > 255, so we have to convert from big endian
      Word16 -> Either SerialiseAsRawBytesError Word16
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> Either SerialiseAsRawBytesError Word16)
-> Word16 -> Either SerialiseAsRawBytesError Word16
forall a b. (a -> b) -> a -> b
$ Word16
b0 Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
b1
    [Word16]
_ ->
      -- we cannot have more than two bytes for Word16
      SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError Word16
forall a.
SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SerialiseAsRawBytesError
 -> Either SerialiseAsRawBytesError Word16)
-> (String -> SerialiseAsRawBytesError)
-> String
-> Either SerialiseAsRawBytesError Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError (String -> Either SerialiseAsRawBytesError Word16)
-> String -> Either SerialiseAsRawBytesError Word16
forall a b. (a -> b) -> a -> b
$
        String
"Cannot decode Word16 from (hex): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSC.unpack (ByteString -> ByteString
Base16.encode ByteString
bs)

instance SerialiseAsRawBytes BS.ByteString where
  serialiseToRawBytes :: ByteString -> ByteString
serialiseToRawBytes = ByteString -> ByteString
forall a. a -> a
id
  deserialiseFromRawBytes :: AsType ByteString
-> ByteString -> Either SerialiseAsRawBytesError ByteString
deserialiseFromRawBytes AsType ByteString
R:AsTypeByteString
AsByteString = ByteString -> Either SerialiseAsRawBytesError ByteString
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

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

deserialiseFromRawBytesHex
  :: forall a
   . SerialiseAsRawBytes a
  => ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex :: forall a.
SerialiseAsRawBytes a =>
ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex ByteString
hex = do
  let type' :: TypeRep
type' = AsType a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (AsType a -> TypeRep) -> AsType a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. HasTypeProxy t => AsType t
asType @a
  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 -> TypeRep -> String -> RawBytesHexError
RawBytesHexErrorBase16DecodeFail ByteString
hex TypeRep
type') (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
  first (RawBytesHexErrorRawBytesDecodeFail hex type') $
    deserialiseFromRawBytes asType raw

-- | Parse hex representation of a value
parseRawBytesHex :: SerialiseAsRawBytes a => P.Parser a
parseRawBytesHex :: forall a. SerialiseAsRawBytes a => Parser a
parseRawBytesHex = do
  input <- ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
P.many ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.hexDigit
  failEitherError . deserialiseFromRawBytesHex $ BSC.pack input

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

instance Error RawBytesHexError where
  prettyError :: forall ann. RawBytesHexError -> Doc ann
prettyError = \case
    RawBytesHexErrorBase16DecodeFail ByteString
input TypeRep
typeRep' String
message ->
      Doc ann
"Failed to deserialise "
        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
typeRep'
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> 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
typeRep' (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
typeRep' 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

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 -> String -> String
[SerialiseAsRawBytesError] -> String -> String
SerialiseAsRawBytesError -> String
(Int -> SerialiseAsRawBytesError -> String -> String)
-> (SerialiseAsRawBytesError -> String)
-> ([SerialiseAsRawBytesError] -> String -> String)
-> Show SerialiseAsRawBytesError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SerialiseAsRawBytesError -> String -> String
showsPrec :: Int -> SerialiseAsRawBytesError -> String -> String
$cshow :: SerialiseAsRawBytesError -> String
show :: SerialiseAsRawBytesError -> String
$cshowList :: [SerialiseAsRawBytesError] -> String -> String
showList :: [SerialiseAsRawBytesError] -> String -> String
Show)

instance Error SerialiseAsRawBytesError where
  prettyError :: forall ann. SerialiseAsRawBytesError -> Doc ann
prettyError = String -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow (String -> Doc ann)
-> (SerialiseAsRawBytesError -> String)
-> SerialiseAsRawBytesError
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialiseAsRawBytesError -> String
unSerialiseAsRawBytesError