{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
module Codec.Extras.SerialiseViaFlat
    ( SerialiseViaFlat (..)
    , decodeViaFlatWith
    , DeserialiseFailureInfo (..)
    , DeserialiseFailureReason (..)
    , readDeserialiseFailureInfo
    ) where

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Read qualified as CBOR
import Codec.Serialise (Serialise, decode, encode)
import Data.Either.Extras (fromRightM)
import Flat qualified
import Flat.Decoder qualified as Flat
import Prettyprinter (Pretty (pretty), (<+>))

{- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance
  that just encodes the flat-serialized value as a CBOR bytestring
-}
newtype SerialiseViaFlat a = SerialiseViaFlat { forall a. SerialiseViaFlat a -> a
unSerialiseViaFlat :: a }

instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where
  encode :: SerialiseViaFlat a -> Encoding
encode = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding)
-> (SerialiseViaFlat a -> ByteString)
-> SerialiseViaFlat a
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Flat a => a -> ByteString
Flat.flat (a -> ByteString)
-> (SerialiseViaFlat a -> a) -> SerialiseViaFlat a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialiseViaFlat a -> a
forall a. SerialiseViaFlat a -> a
unSerialiseViaFlat
  decode :: forall s. Decoder s (SerialiseViaFlat a)
decode = a -> SerialiseViaFlat a
forall a. a -> SerialiseViaFlat a
SerialiseViaFlat (a -> SerialiseViaFlat a)
-> Decoder s a -> Decoder s (SerialiseViaFlat a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a -> Decoder s a
forall a s. Get a -> Decoder s a
decodeViaFlatWith Get a
forall a. Flat a => Get a
Flat.decode

decodeViaFlatWith :: Flat.Get a -> CBOR.Decoder s a
decodeViaFlatWith :: forall a s. Get a -> Decoder s a
decodeViaFlatWith Get a
decoder = do
  ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes
  -- lift any flat's failures to be cborg failures (MonadFail)
  (DecodeException -> Decoder s a)
-> Either DecodeException a -> Decoder s a
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Either a b -> m b
fromRightM (String -> Decoder s a
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s a)
-> (DecodeException -> String) -> DecodeException -> Decoder s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeException -> String
forall a. Show a => a -> String
show) (Either DecodeException a -> Decoder s a)
-> Either DecodeException a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Get a -> ByteString -> Either DecodeException a
forall b a. AsByteString b => Get a -> b -> Decoded a
Flat.unflatWith Get a
decoder ByteString
bs

{- | The errors returned by `cborg` are plain strings (untyped). With this
function we try to map onto datatypes, those cborg error messages that we are
interested in.

Currently we are only interested in error messages returned by the
`CBOR.decodeBytes` decoder;
see `PlutusLedgerApi.Common.SerialisedScript.scriptCBORDecoder`.
-}
readDeserialiseFailureInfo :: CBOR.DeserialiseFailure -> DeserialiseFailureInfo
readDeserialiseFailureInfo :: DeserialiseFailure -> DeserialiseFailureInfo
readDeserialiseFailureInfo (CBOR.DeserialiseFailure ByteOffset
byteOffset String
reason) =
  ByteOffset -> DeserialiseFailureReason -> DeserialiseFailureInfo
DeserialiseFailureInfo ByteOffset
byteOffset (DeserialiseFailureReason -> DeserialiseFailureInfo)
-> DeserialiseFailureReason -> DeserialiseFailureInfo
forall a b. (a -> b) -> a -> b
$ String -> DeserialiseFailureReason
interpretReason String
reason
 where
  -- Note that this is subject to change if `cborg` dependency changes.
  -- Currently: cborg-0.2.10.0
  interpretReason :: String -> DeserialiseFailureReason
  interpretReason :: String -> DeserialiseFailureReason
interpretReason = \case
    -- Relevant Sources:
    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L226>
    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1424>
    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1441>
    String
"end of input" -> DeserialiseFailureReason
EndOfInput
    -- Relevant Sources:
    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1051>
    String
"expected bytes" -> DeserialiseFailureReason
ExpectedBytes
    String
msg -> String -> DeserialiseFailureReason
OtherReason String
msg

{- | Similar to `CBOR.DeserialiseFailure`, with the difference that plain
string reason messages are turned into the datatype: `DeserialiseFailureReason`.
-}
data DeserialiseFailureInfo = DeserialiseFailureInfo
  { DeserialiseFailureInfo -> ByteOffset
dfOffset :: CBOR.ByteOffset
  , DeserialiseFailureInfo -> DeserialiseFailureReason
dfReason :: DeserialiseFailureReason
  }
  deriving stock (DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool
(DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool)
-> (DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool)
-> Eq DeserialiseFailureInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool
== :: DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool
$c/= :: DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool
/= :: DeserialiseFailureInfo -> DeserialiseFailureInfo -> Bool
Eq, Int -> DeserialiseFailureInfo -> ShowS
[DeserialiseFailureInfo] -> ShowS
DeserialiseFailureInfo -> String
(Int -> DeserialiseFailureInfo -> ShowS)
-> (DeserialiseFailureInfo -> String)
-> ([DeserialiseFailureInfo] -> ShowS)
-> Show DeserialiseFailureInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeserialiseFailureInfo -> ShowS
showsPrec :: Int -> DeserialiseFailureInfo -> ShowS
$cshow :: DeserialiseFailureInfo -> String
show :: DeserialiseFailureInfo -> String
$cshowList :: [DeserialiseFailureInfo] -> ShowS
showList :: [DeserialiseFailureInfo] -> ShowS
Show)

instance Pretty DeserialiseFailureInfo where
  pretty :: forall ann. DeserialiseFailureInfo -> Doc ann
pretty (DeserialiseFailureInfo ByteOffset
offset DeserialiseFailureReason
reason) =
    Doc ann
"CBOR deserialisation failed at the offset"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ByteOffset -> Doc ann
forall ann. ByteOffset -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ByteOffset
offset
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"for the following reason:"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DeserialiseFailureReason -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DeserialiseFailureReason -> Doc ann
pretty DeserialiseFailureReason
reason

-- | The reason of the cbor failure as a datatype, not as a plain string.
data DeserialiseFailureReason
  = -- | Not enough input provided
    EndOfInput
  | -- | The bytes inside the input are malformed.
    ExpectedBytes
  | -- | This is either a cbor failure that we (plutus) are not aware of,
    -- or an underlying flat failure. We use whatever message `cborg` or flat returns.
    OtherReason String
  deriving stock (DeserialiseFailureReason -> DeserialiseFailureReason -> Bool
(DeserialiseFailureReason -> DeserialiseFailureReason -> Bool)
-> (DeserialiseFailureReason -> DeserialiseFailureReason -> Bool)
-> Eq DeserialiseFailureReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeserialiseFailureReason -> DeserialiseFailureReason -> Bool
== :: DeserialiseFailureReason -> DeserialiseFailureReason -> Bool
$c/= :: DeserialiseFailureReason -> DeserialiseFailureReason -> Bool
/= :: DeserialiseFailureReason -> DeserialiseFailureReason -> Bool
Eq, Int -> DeserialiseFailureReason -> ShowS
[DeserialiseFailureReason] -> ShowS
DeserialiseFailureReason -> String
(Int -> DeserialiseFailureReason -> ShowS)
-> (DeserialiseFailureReason -> String)
-> ([DeserialiseFailureReason] -> ShowS)
-> Show DeserialiseFailureReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeserialiseFailureReason -> ShowS
showsPrec :: Int -> DeserialiseFailureReason -> ShowS
$cshow :: DeserialiseFailureReason -> String
show :: DeserialiseFailureReason -> String
$cshowList :: [DeserialiseFailureReason] -> ShowS
showList :: [DeserialiseFailureReason] -> ShowS
Show)

instance Pretty DeserialiseFailureReason where
  pretty :: forall ann. DeserialiseFailureReason -> Doc ann
pretty = \case
    DeserialiseFailureReason
EndOfInput -> Doc ann
"reached the end of input while more data was expected."
    DeserialiseFailureReason
ExpectedBytes -> Doc ann
"the bytes inside the input are malformed."
    OtherReason String
msg -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg