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

module Cardano.Ledger.Binary.Decoding (
  -- * Running decoders
  decodeFull,
  decodeFull',
  decodeFullDecoder,
  decodeFullDecoder',
  decodeFullAnnotator,
  decodeFullAnnotatedBytes,
  decodeFullAnnotatorFromHexText,
  module Cardano.Ledger.Binary.Version,
  module Cardano.Ledger.Binary.Decoding.DecCBOR,
  module Cardano.Ledger.Binary.Decoding.Sharing,
  module Cardano.Ledger.Binary.Decoding.Decoder,
  module Cardano.Ledger.Binary.Decoding.Sized,
  module Cardano.Ledger.Binary.Decoding.Drop,

  -- * Annotated

  --
  -- $annotated
  module Cardano.Ledger.Binary.Decoding.Annotated,

  -- * Nested CBOR in CBOR
  decodeNestedCbor,
  decodeNestedCborBytes,

  -- * Unsafe deserialization
  unsafeDeserialize,
  unsafeDeserialize',

  -- * Helpers
  toStrictByteString,
  decodeMemPack,
)
where

import Cardano.Ledger.Binary.Decoding.Annotated
import Cardano.Ledger.Binary.Decoding.DecCBOR
import Cardano.Ledger.Binary.Decoding.Decoder hiding (getOriginalBytes)
import Cardano.Ledger.Binary.Decoding.Drop
import Cardano.Ledger.Binary.Decoding.Sharing
import Cardano.Ledger.Binary.Decoding.Sized
import Cardano.Ledger.Binary.Plain (withHexText)
import Cardano.Ledger.Binary.Version
import Codec.CBOR.Read as Read (DeserialiseFailure, IDecode (..), deserialiseIncremental)
import Codec.CBOR.Write (toStrictByteString)
import Control.Exception (displayException)
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.MemPack
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)

-- | Deserialize a Haskell value from the external binary representation, which
-- have been made using 'serialize' or a matching serialization functionilty in
-- another language that uses CBOR format. Accepts lazy `BSL.ByteString` as
-- input, for strict variant use `unsafeDeserialize'` instead.
--
-- This deserializaer is not safe for these reasons:
--
-- *  /Throws/: @'Read.DeserialiseFailure'@ if the given external
--   representation is invalid or does not correspond to a value of the
--   expected type.
--
-- * Decoding will not fail when the binary input is not consumed in full.
unsafeDeserialize ::
  DecCBOR a =>
  Version ->
  BSL.ByteString ->
  a
unsafeDeserialize :: forall a. DecCBOR a => Version -> ByteString -> a
unsafeDeserialize Version
version =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> [Char]
displayException) 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.
Version
-> (forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder Version
version forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Variant of 'unsafeDeserialize' that accepts a strict `BS.ByteString` as
-- input.
unsafeDeserialize' :: DecCBOR a => Version -> BS.ByteString -> a
unsafeDeserialize' :: forall a. DecCBOR a => Version -> ByteString -> a
unsafeDeserialize' Version
version = forall a. DecCBOR a => Version -> ByteString -> a
unsafeDeserialize Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict

-- | Deserialize a Haskell value from a binary CBOR representation, failing if
--   there are leftovers. In other words, the __Full__ here implies the contract
--   on this function that the input must be consumed in its entirety by the
--   decoder specified in `DecCBOR`.
decodeFull :: forall a. DecCBOR a => Version -> BSL.ByteString -> Either DecoderError a
decodeFull :: forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version = forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
version (forall a. DecCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a) forall a s. DecCBOR a => Decoder s a
decCBOR
{-# INLINE decodeFull #-}

-- | Same as `decodeFull`, except accepts a strict `BS.ByteString` as input
-- instead of the lazy one.
decodeFull' :: forall a. DecCBOR a => Version -> BS.ByteString -> Either DecoderError a
decodeFull' :: forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
version = forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
{-# INLINE decodeFull' #-}

-- | Same as `decodeFull`, except instead of relying on the `DecCBOR` instance
-- the `Decoder` must be suplied manually.
decodeFullDecoder ::
  -- | Protocol version to be used during decoding.
  Version ->
  -- | 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. Decoder s a) ->
  -- | The @ByteString@ to decode
  BSL.ByteString ->
  Either DecoderError a
decodeFullDecoder :: forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
version Text
lbl forall s. Decoder s a
decoder ByteString
bs =
  case forall a.
Version
-> (forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder Version
version forall s. Decoder s a
decoder ByteString
bs 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
{-# INLINE decodeFullDecoder #-}

-- | Same as `decodeFullDecoder`, except works on strict `BS.ByteString`
decodeFullDecoder' ::
  Version ->
  Text ->
  (forall s. Decoder s a) ->
  BS.ByteString ->
  Either DecoderError a
decodeFullDecoder' :: forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder' Version
version Text
lbl forall s. Decoder s a
decoder = forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
version Text
lbl forall s. Decoder s a
decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
{-# INLINE decodeFullDecoder' #-}

-- | Deserialise a Haskell type from a 'BSL.ByteString' input, which be consumed
-- incrementally using the provided 'Decoder'. Unlike `decodeFullDecoder` there
-- is no requiremenet to consume all input, therefore left over binary input is
-- returned upon sucessfull or failed deserialization.
deserialiseDecoder ::
  Version ->
  (forall s. Decoder s a) ->
  BSL.ByteString ->
  Either (Read.DeserialiseFailure, BS.ByteString) (a, BS.ByteString)
deserialiseDecoder :: forall a.
Version
-> (forall s. Decoder s a)
-> ByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder Version
version forall s. Decoder s a
decoder ByteString
bsl =
  forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$
    forall s a.
ByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput ByteString
bsl 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 a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder (forall a. a -> Maybe a
Just ByteString
bsl) Version
version forall s. Decoder s a
decoder)
{-# INLINE deserialiseDecoder #-}

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))
{-# INLINE supplyAllInput #-}

--------------------------------------------------------------------------------
-- Annotator
--------------------------------------------------------------------------------

-- | Same as `decodeFullDecoder`, except it provdes the means of passing portion or all
-- of the `BSL.ByteString` input argument to the decoding `Annotator`.
decodeFullAnnotator ::
  Version ->
  Text ->
  (forall s. Decoder s (Annotator a)) ->
  BSL.ByteString ->
  Either DecoderError a
decodeFullAnnotator :: forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
v Text
lbl forall s. Decoder s (Annotator a)
decoder ByteString
bytes =
  (\Annotator a
x -> forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator a
x (ByteString -> FullByteString
Full ByteString
bytes)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
v Text
lbl forall s. Decoder s (Annotator a)
decoder ByteString
bytes
{-# INLINE decodeFullAnnotator #-}

-- | Same as `decodeFullDecoder`, decodes a Haskell value from a lazy
-- `BSL.ByteString`, requiring that the full ByteString is consumed, and
-- replaces `ByteSpan` annotations with the corresponding slice of the input as
-- a strict `BS.ByteString`.
decodeFullAnnotatedBytes ::
  Functor f =>
  Version ->
  Text ->
  (forall s. Decoder s (f ByteSpan)) ->
  BSL.ByteString ->
  Either DecoderError (f BS.ByteString)
decodeFullAnnotatedBytes :: forall (f :: * -> *).
Functor f =>
Version
-> Text
-> (forall s. Decoder s (f ByteSpan))
-> ByteString
-> Either DecoderError (f ByteString)
decodeFullAnnotatedBytes Version
v Text
lbl forall s. Decoder s (f ByteSpan)
decoder ByteString
bytes =
  forall (f :: * -> *).
Functor f =>
ByteString -> f ByteSpan -> f ByteString
annotationBytes ByteString
bytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
v Text
lbl forall s. Decoder s (f ByteSpan)
decoder ByteString
bytes
{-# INLINE decodeFullAnnotatedBytes #-}

decodeFullAnnotatorFromHexText ::
  Version ->
  Text ->
  (forall s. Decoder s (Annotator a)) ->
  Text ->
  Either DecoderError a
decodeFullAnnotatorFromHexText :: forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> Text
-> Either DecoderError a
decodeFullAnnotatorFromHexText Version
v Text
desc forall s. Decoder s (Annotator a)
dec =
  forall b.
(ByteString -> Either DecoderError b)
-> Text -> Either DecoderError b
withHexText forall a b. (a -> b) -> a -> b
$ forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
v Text
desc forall s. Decoder s (Annotator a)
dec forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
{-# INLINE decodeFullAnnotatorFromHexText #-}

--------------------------------------------------------------------------------
-- 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 :: Decoder s ()
decodeNestedCborTag :: forall s. Decoder s ()
decodeNestedCborTag = do
  Word
t <- forall s. Decoder s Word
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)
{-# INLINE decodeNestedCborTag #-}

-- | 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 :: DecCBOR a => Decoder s a
decodeNestedCbor :: forall a s. DecCBOR a => Decoder s a
decodeNestedCbor = do
  ByteString
bs <- forall s. Decoder s ByteString
decodeNestedCborBytes
  Version
version <- forall s. Decoder s Version
getDecoderVersion
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
version ByteString
bs
{-# INLINE decodeNestedCbor #-}

-- | 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 :: Decoder s BS.ByteString
decodeNestedCborBytes :: forall s. Decoder s ByteString
decodeNestedCborBytes = forall s. Decoder s ()
decodeNestedCborTag forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. Decoder s ByteString
decodeBytes
{-# INLINE decodeNestedCborBytes #-}

-- $annotated
--
-- The regular CBOR 'Decoder' does not support access to the original 'BSL.ByteString' that is
-- being read during deserialization. The 'Annotator' and 'Annotated' recover this ability.
--
-- 1. 'ByteSpan'  A pair of indexes into a bytestring, indicating a substring.
-- 2. 'Annotated'  Used in practice to pair a value with a 'ByteSpan'. Mostly used in Byron codebase.
-- 3. 'FullByteString' A newtype (around a bytestring) used to store the original bytestring being deserialized.
-- 4. 'Annotator' An explict reader monad whose environment is a 'FullByteString'
--
-- The basic idea is, for a given type @t@, where we need the original 'BSL.ByteString', either
--
-- 1. To complete the deserialization, or
-- 2. To combine the deserialized answer with the original 'BSL.ByteString'.
--
-- We should proceed as follows: Define instances @('DecCBOR' ('Annotator' t))@ instead
-- of @('DecCBOR' t)@. When making this instance we may freely use that both 'Decoder'
-- and 'Annotator' are both monads, and that functions 'withSlice' and 'annotatorSlice'
-- provide access to the original bytes, or portions thereof, inside of decoders.  Then,
-- to actually decode a value of type @t@, we use something similar to the following code
-- fragment.
--
-- @
-- howToUseFullBytes bytes = do
--   Annotator f <- decodeFullDecoder \"DecodingAnnotator\" (decCBOR :: forall s. Decoder s (Annotator t)) bytes
--   pure (f (Full bytes))
-- @
--
-- Decode the bytes to get an @('Annotator' f)@ where f is a function that when given
-- original bytes produces a value of type @t@, then apply @f@ to @('Full' bytes)@ to get
-- the answer.

-- | First decode as CBOR bytes and then use MemPack unpacker on it
decodeMemPack :: MemPack a => Decoder s a
decodeMemPack :: forall a s. MemPack a => Decoder s a
decodeMemPack = forall a b (m :: * -> *).
(MemPack a, Buffer b, MonadFail m) =>
b -> m a
unpackMonadFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> ByteArray
unBA forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Decoder s ByteArray
decodeByteArray