{-# 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 (..), FiniteBits (finiteBitSize))
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as BSL
import Data.Data (typeRep)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Typeable (TypeRep, Typeable)
import Data.Word (Word16, Word32, Word64, Word8)
import Numeric.Natural (Natural)

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 -> Either SerialiseAsRawBytesError Word8
forall a.
(FiniteBits a, Typeable a, Num a) =>
ByteString -> Either SerialiseAsRawBytesError a
deserialiseWord

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 -> Either SerialiseAsRawBytesError Word16
forall a.
(FiniteBits a, Typeable a, Num a) =>
ByteString -> Either SerialiseAsRawBytesError a
deserialiseWord

instance SerialiseAsRawBytes Word32 where
  serialiseToRawBytes :: Word32 -> ByteString
serialiseToRawBytes = LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Word32 -> LazyByteString) -> Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BSB.toLazyByteString (Builder -> LazyByteString)
-> (Word32 -> Builder) -> Word32 -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BSB.word32BE
  deserialiseFromRawBytes :: AsType Word32
-> ByteString -> Either SerialiseAsRawBytesError Word32
deserialiseFromRawBytes AsType Word32
R:AsTypeWord32
AsWord32 = ByteString -> Either SerialiseAsRawBytesError Word32
forall a.
(FiniteBits a, Typeable a, Num a) =>
ByteString -> Either SerialiseAsRawBytesError a
deserialiseWord

instance SerialiseAsRawBytes Word64 where
  serialiseToRawBytes :: Word64 -> ByteString
serialiseToRawBytes = LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Word64 -> LazyByteString) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BSB.toLazyByteString (Builder -> LazyByteString)
-> (Word64 -> Builder) -> Word64 -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
BSB.word64BE
  deserialiseFromRawBytes :: AsType Word64
-> ByteString -> Either SerialiseAsRawBytesError Word64
deserialiseFromRawBytes AsType Word64
R:AsTypeWord64
AsWord64 = ByteString -> Either SerialiseAsRawBytesError Word64
forall a.
(FiniteBits a, Typeable a, Num a) =>
ByteString -> Either SerialiseAsRawBytesError a
deserialiseWord

-- | Deserialise any length number. Does not require the input to have the byte length of the target type.
deserialiseWord
  :: forall a
   . (FiniteBits a, Typeable a, Num a)
  => ByteString
  -- ^ bytes representation of the number
  -> Either SerialiseAsRawBytesError a
deserialiseWord :: forall a.
(FiniteBits a, Typeable a, Num a) =>
ByteString -> Either SerialiseAsRawBytesError a
deserialiseWord ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs =
      SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a)
-> SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall a b. (a -> b) -> a -> b
$
        String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError (String -> SerialiseAsRawBytesError)
-> String -> SerialiseAsRawBytesError
forall a b. (a -> b) -> a -> b
$
          String
"Cannot deserialise empty bytes into " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typeName
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBytes =
      SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a)
-> SerialiseAsRawBytesError -> Either SerialiseAsRawBytesError a
forall a b. (a -> b) -> a -> b
$
        String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError (String -> SerialiseAsRawBytesError)
-> String -> SerialiseAsRawBytesError
forall a b. (a -> b) -> a -> b
$
          String
"Cannot decode " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": Value too large (hex):" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSC.unpack (ByteString -> ByteString
Base16.encode ByteString
bs)
  | Bool
otherwise =
      a -> Either SerialiseAsRawBytesError a
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either SerialiseAsRawBytesError a)
-> a -> Either SerialiseAsRawBytesError a
forall a b. (a -> b) -> a -> b
$ (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\a
acc Word8
b -> a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) a
0 ByteString
bs
 where
  maxBytes :: Int
maxBytes = a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (forall a. Bits a => a
zeroBits @a) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
  typeName :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

-- | Convert the number into binary value
instance SerialiseAsRawBytes Natural where
  serialiseToRawBytes :: Natural -> ByteString
serialiseToRawBytes Natural
0 = Word8 -> ByteString
BS.singleton Word8
0x00
  serialiseToRawBytes Natural
n = LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BSB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Natural -> Builder -> Builder
forall {a}. (Bits a, Integral a) => a -> Builder -> Builder
go Natural
n Builder
forall a. Monoid a => a
mempty
   where
    go :: a -> Builder -> Builder
go a
0 Builder
acc = Builder
acc
    go a
x Builder
acc = a -> Builder -> Builder
go (a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) (Word8 -> Builder
BSB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
x a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc)
  deserialiseFromRawBytes :: AsType Natural
-> ByteString -> Either SerialiseAsRawBytesError Natural
deserialiseFromRawBytes AsType Natural
R:AsTypeNatural
AsNatural ByteString
"\x00" = Natural -> Either SerialiseAsRawBytesError Natural
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0
  deserialiseFromRawBytes AsType Natural
R:AsTypeNatural
AsNatural ByteString
input = Natural -> Either SerialiseAsRawBytesError Natural
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Either SerialiseAsRawBytesError Natural)
-> Natural -> Either SerialiseAsRawBytesError Natural
forall a b. (a -> b) -> a -> b
$ (Natural -> Word8 -> Natural) -> Natural -> ByteString -> Natural
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Natural
acc Word8
byte -> Natural
acc Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byte) Natural
0 ByteString
input

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:AsTypeByteString1
AsByteString = ByteString -> Either SerialiseAsRawBytesError ByteString
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance SerialiseAsRawBytes BSL.ByteString where
  serialiseToRawBytes :: LazyByteString -> ByteString
serialiseToRawBytes = LazyByteString -> ByteString
BSL.toStrict
  deserialiseFromRawBytes :: AsType LazyByteString
-> ByteString -> Either SerialiseAsRawBytesError LazyByteString
deserialiseFromRawBytes AsType LazyByteString
R:AsTypeByteString
AsByteStringLazy = LazyByteString -> Either SerialiseAsRawBytesError LazyByteString
forall a. a -> Either SerialiseAsRawBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LazyByteString -> Either SerialiseAsRawBytesError LazyByteString)
-> (ByteString -> LazyByteString)
-> ByteString
-> Either SerialiseAsRawBytesError LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LazyByteString
BSL.fromStrict

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