{-# 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

  -- * Backward-compatible functions
  , decodeFull
  , decodeFull'
  , decodeFullDecoder

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

import Cardano.Prelude

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 qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Internal as BSL

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


-- | 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 => LByteString -> a
unsafeDeserialize :: LByteString -> a
unsafeDeserialize =
  (DeserialiseFailure -> a)
-> (a -> a) -> Either DeserialiseFailure a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either DeserialiseFailure -> a
forall e a. Exception e => e -> a
impureThrow a -> a
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (Either DeserialiseFailure a -> a)
-> (LByteString -> Either DeserialiseFailure a) -> LByteString -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((DeserialiseFailure, ByteString) -> DeserialiseFailure)
-> ((a, ByteString) -> a)
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
-> Either DeserialiseFailure a
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (DeserialiseFailure, ByteString) -> DeserialiseFailure
forall a b. (a, b) -> a
fst (a, ByteString) -> a
forall a b. (a, b) -> a
fst (Either (DeserialiseFailure, ByteString) (a, ByteString)
 -> Either DeserialiseFailure a)
-> (LByteString
    -> Either (DeserialiseFailure, ByteString) (a, ByteString))
-> LByteString
-> Either DeserialiseFailure a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall s. Decoder s a)
-> LByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
forall a.
(forall s. Decoder s a)
-> LByteString
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
deserialiseDecoder forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Strict variant of 'deserialize'.
unsafeDeserialize' :: FromCBOR a => ByteString -> a
unsafeDeserialize' :: ByteString -> a
unsafeDeserialize' = LByteString -> a
forall a. FromCBOR a => LByteString -> a
unsafeDeserialize (LByteString -> a)
-> (ByteString -> LByteString) -> ByteString -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> LByteString
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 => LByteString -> Either DecoderError a
decodeFull :: LByteString -> Either DecoderError a
decodeFull = Text
-> (forall s. Decoder s a) -> LByteString -> Either DecoderError a
forall a.
Text
-> (forall s. Decoder s a) -> LByteString -> Either DecoderError a
decodeFullDecoder (Proxy a -> Text
forall a. FromCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a) forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

decodeFull' :: forall a . FromCBOR a => ByteString -> Either DecoderError a
decodeFull' :: ByteString -> Either DecoderError a
decodeFull' = LByteString -> Either DecoderError a
forall a. FromCBOR a => LByteString -> Either DecoderError a
decodeFull (LByteString -> Either DecoderError a)
-> (ByteString -> LByteString)
-> ByteString
-> Either DecoderError a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> LByteString
BSL.fromStrict

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

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

supplyAllInput
  :: LByteString
  -> Read.IDecode s a
  -> ST s (Either (Read.DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput :: LByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput LByteString
bs' (Read.Done ByteString
bs ByteOffset
_ a
x) =
  Either (DeserialiseFailure, ByteString) (a, ByteString)
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, ByteString)
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
forall a b. b -> Either a b
Right (a
x, ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> LByteString -> ByteString
BSL.toStrict LByteString
bs'))
supplyAllInput LByteString
bs (Read.Partial Maybe ByteString -> ST s (IDecode s a)
k) = case LByteString
bs of
  BSL.Chunk ByteString
chunk LByteString
bs' -> Maybe ByteString -> ST s (IDecode s a)
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk) ST s (IDecode s a)
-> (IDecode s a
    -> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString)))
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall s a.
LByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput LByteString
bs'
  LByteString
BSL.Empty           -> Maybe ByteString -> ST s (IDecode s a)
k Maybe ByteString
forall a. Maybe a
Nothing ST s (IDecode s a)
-> (IDecode s a
    -> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString)))
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall s a.
LByteString
-> IDecode s a
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
supplyAllInput LByteString
BSL.Empty
supplyAllInput LByteString
_ (Read.Fail ByteString
bs ByteOffset
_ DeserialiseFailure
exn) = Either (DeserialiseFailure, ByteString) (a, ByteString)
-> ST s (Either (DeserialiseFailure, ByteString) (a, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return ((DeserialiseFailure, ByteString)
-> Either (DeserialiseFailure, ByteString) (a, ByteString)
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 :: Decoder s ()
decodeNestedCborTag = do
  Word
t <- Decoder s Word
forall s. Decoder s Word
D.decodeTag
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
24) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag
    Text
"decodeNestedCborTag"
    (Word -> Word8
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 :: Decoder s a
decodeNestedCbor = do
  ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
decodeNestedCborBytes
  Either DecoderError a -> Decoder s a
forall e a s. Buildable e => Either e a -> Decoder s a
toCborError (Either DecoderError a -> Decoder s a)
-> Either DecoderError a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either DecoderError a
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 ByteString
decodeNestedCborBytes :: Decoder s ByteString
decodeNestedCborBytes = do
  Decoder s ()
forall s. Decoder s ()
decodeNestedCborTag
  Decoder s ByteString
forall s. Decoder s ByteString
D.decodeBytes