{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Deserialization primitives built on top of the @FromCBOR@ typeclass
module Cardano.Binary.Deserialize (
  -- * Unsafe deserialization
  unsafeDeserialize,
  unsafeDeserialize',
  CBOR.Write.toStrictByteString,

  -- * Decoding
  decodeFull,
  decodeFull',
  decodeFullDecoder,
  decodeFullDecoder',

  -- * CBOR in CBOR
  decodeNestedCbor,
  decodeNestedCborBytes,
)
where

import qualified Codec.CBOR.Decoding as D
import qualified Codec.CBOR.Read as Read
import qualified Codec.CBOR.Write as CBOR.Write
import Control.Exception.Safe (impureThrow)
import Control.Monad (when)
import Control.Monad.ST (ST, runST)
import Data.Bifunctor (bimap)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Internal as BSL
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)

import Cardano.Binary.FromCBOR (DecoderError (..), FromCBOR (..), cborError, toCborError)

-- | Deserialize a Haskell value from the external binary representation
--   (which must have been made using 'serialize' or related function).
--
--   /Throws/: @'Read.DeserialiseFailure'@ if the given external
--   representation is invalid or does not correspond to a value of the
--   expected type.
unsafeDeserialize :: FromCBOR a => BSL.ByteString -> a
unsafeDeserialize :: forall a. FromCBOR a => ByteString -> a
unsafeDeserialize =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> a
impureThrow forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> a
fst forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Strict variant of 'deserialize'.
unsafeDeserialize' :: FromCBOR a => BS.ByteString -> a
unsafeDeserialize' :: forall a. FromCBOR a => ByteString -> a
unsafeDeserialize' = forall a. FromCBOR a => ByteString -> a
unsafeDeserialize forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict

-- | Deserialize a Haskell value from the external binary representation,
--   failing if there are leftovers. In a nutshell, the `full` here implies
--   the contract of this function is that what you feed as input needs to
--   be consumed entirely.
decodeFull :: forall a. FromCBOR a => BSL.ByteString -> Either DecoderError a
decodeFull :: forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull = forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder (forall a. FromCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a) forall a s. FromCBOR a => Decoder s a
fromCBOR

decodeFull' :: forall a. FromCBOR a => BS.ByteString -> Either DecoderError a
decodeFull' :: forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' = forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict

decodeFullDecoder ::
  -- | Label for error reporting
  Text ->
  -- | The parser for the @ByteString@ to decode. It should decode the given
  -- @ByteString@ into a value of type @a@
  (forall s. D.Decoder s a) ->
  -- | The @ByteString@ to decode
  BSL.ByteString ->
  Either DecoderError a
decodeFullDecoder :: forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
lbl forall s. Decoder s a
decoder ByteString
bs0 = case forall a.
(forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder forall s. Decoder s a
decoder ByteString
bs0 of
  Right (a
x, ByteString
leftover) ->
    if ByteString -> Bool
BS.null ByteString
leftover
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> DecoderError
DecoderErrorLeftover Text
lbl ByteString
leftover
  Left (DeserialiseFailure
e, ByteString
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> DeserialiseFailure -> DecoderError
DecoderErrorDeserialiseFailure Text
lbl DeserialiseFailure
e

decodeFullDecoder' ::
  -- | Label for error reporting
  Text ->
  -- | The parser for the @ByteString@ to decode. It should decode the given
  -- @ByteString@ into a value of type @a@
  (forall s. D.Decoder s a) ->
  -- | The @ByteString@ to decode
  BS.ByteString ->
  Either DecoderError a
decodeFullDecoder' :: forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder' Text
lbl forall s. Decoder s a
decoder = forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
lbl forall s. Decoder s a
decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict

-- | Deserialise a 'LByteString' incrementally using the provided 'Decoder'
deserialiseDecoder ::
  (forall s. D.Decoder s a) ->
  BSL.ByteString ->
  Either (Read.DeserialiseFailure, BS.ByteString) (a, BS.ByteString)
deserialiseDecoder :: forall a.
(forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder forall s. Decoder s a
decoder ByteString
bs0 =
  forall a. (forall s. ST s a) -> a
runST (forall s a.
ByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput ByteString
bs0 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s a. Decoder s a -> ST s (IDecode s a)
Read.deserialiseIncremental forall s. Decoder s a
decoder)

supplyAllInput ::
  BSL.ByteString ->
  Read.IDecode s a ->
  ST s (Either (Read.DeserialiseFailure, BS.ByteString) (a, BS.ByteString))
supplyAllInput :: forall s a.
ByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput ByteString
bs' (Read.Done ByteString
bs ByteOffset
_ a
x) =
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (a
x, ByteString
bs forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict ByteString
bs'))
supplyAllInput ByteString
bs (Read.Partial Maybe ByteString -> ST s (IDecode s a)
k) = case ByteString
bs of
  BSL.Chunk ByteString
chunk ByteString
bs' -> Maybe ByteString -> ST s (IDecode s a)
k (forall a. a -> Maybe a
Just ByteString
chunk) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s a.
ByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput ByteString
bs'
  ByteString
BSL.Empty -> Maybe ByteString -> ST s (IDecode s a)
k forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s a.
ByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput ByteString
BSL.Empty
supplyAllInput ByteString
_ (Read.Fail ByteString
bs ByteOffset
_ DeserialiseFailure
exn) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (DeserialiseFailure
exn, ByteString
bs))

--------------------------------------------------------------------------------
-- Nested CBOR-in-CBOR
-- https://tools.ietf.org/html/rfc7049#section-2.4.4.1
--------------------------------------------------------------------------------

-- | Remove the the semantic tag 24 from the enclosed CBOR data item,
-- failing if the tag cannot be found.
decodeNestedCborTag :: D.Decoder s ()
decodeNestedCborTag :: forall s. Decoder s ()
decodeNestedCborTag = do
  Word
t <- forall s. Decoder s Word
D.decodeTag
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
t forall a. Eq a => a -> a -> Bool
/= Word
24) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$
      Text -> Word8 -> DecoderError
DecoderErrorUnknownTag
        Text
"decodeNestedCborTag"
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
t)

-- | Remove the the semantic tag 24 from the enclosed CBOR data item,
-- decoding back the inner `ByteString` as a proper Haskell type.
-- Consume its input in full.
decodeNestedCbor :: FromCBOR a => D.Decoder s a
decodeNestedCbor :: forall a s. FromCBOR a => Decoder s a
decodeNestedCbor = do
  ByteString
bs <- forall s. Decoder s ByteString
decodeNestedCborBytes
  forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError forall a b. (a -> b) -> a -> b
$ forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' ByteString
bs

-- | Like `decodeKnownCborDataItem`, but assumes nothing about the Haskell
-- type we want to deserialise back, therefore it yields the `ByteString`
-- Tag 24 surrounded (stripping such tag away).
--
-- In CBOR notation, if the data was serialised as:
--
-- >>> 24(h'DEADBEEF')
--
-- then `decodeNestedCborBytes` yields the inner 'DEADBEEF', unchanged.
decodeNestedCborBytes :: D.Decoder s BS.ByteString
decodeNestedCborBytes :: forall s. Decoder s ByteString
decodeNestedCborBytes = do
  forall s. Decoder s ()
decodeNestedCborTag
  forall s. Decoder s ByteString
D.decodeBytes