{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Defines reusable abstractions for testing RoundTrip properties of plain encoders/decoders
module Test.Cardano.Ledger.Binary.Plain.RoundTrip (
  roundTripSpec,
  roundTripFailureExpectation,
  roundTripExpectation,
  roundTripCborExpectation,
  embedTripSpec,
  embedTripExpectation,
  RoundTripFailure (..),
  showMaybeDecoderError,
  showFailedTermsWithReSerialization,
  Trip (..),
  mkTrip,
  cborTrip,
  roundTrip,
  embedTrip,
  embedTripLabel,
)
where

import Cardano.Ledger.Binary.Plain
import qualified Codec.CBOR.FlatTerm as CBOR
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy
import qualified Data.Text as Text
import Data.Typeable
import qualified Formatting.Buildable as B (Buildable (..))
import Test.Cardano.Ledger.Binary.TreeDiff (
  CBORBytes (..),
  ansiExprString,
  diffExprString,
  showHexBytesGrouped,
 )
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck hiding (label)

-- =====================================================================

-- | Tests the roundtrip property using QuickCheck generators for all possible versions
-- starting with `shelleyProtVer`.
roundTripSpec ::
  forall t.
  (Show t, Eq t, Typeable t, Arbitrary t) =>
  Trip t t ->
  Spec
roundTripSpec :: forall t.
(Show t, Eq t, Typeable t, Arbitrary t) =>
Trip t t -> Spec
roundTripSpec Trip t t
trip =
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t)) forall a b. (a -> b) -> a -> b
$ forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation Trip t t
trip

-- | Tests the embedtrip property using QuickCheck generators
embedTripSpec ::
  forall a b.
  (Eq b, Show a, Typeable a, Typeable b, Arbitrary a, HasCallStack) =>
  Trip a b ->
  (b -> a -> Expectation) ->
  Spec
embedTripSpec :: forall a b.
(Eq b, Show a, Typeable a, Typeable b, Arbitrary a,
 HasCallStack) =>
Trip a b -> (b -> a -> Expectation) -> Spec
embedTripSpec Trip a b
trip b -> a -> Expectation
f =
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
"From: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a) forall a. [a] -> [a] -> [a]
++ String
" To " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @b)) forall a b. (a -> b) -> a -> b
$
    forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> (b -> a -> Expectation) -> a -> Expectation
embedTripExpectation Trip a b
trip b -> a -> Expectation
f

-- Tests that a decoder error happens
roundTripFailureExpectation :: forall a. (Eq a, ToCBOR a, FromCBOR a) => a -> Expectation
roundTripFailureExpectation :: forall a. (Eq a, ToCBOR a, FromCBOR a) => a -> Expectation
roundTripFailureExpectation a
x =
  case forall t.
(Eq t, Typeable t) =>
Trip t t -> t -> Either RoundTripFailure t
roundTrip (forall a b. (ToCBOR a, FromCBOR b) => Trip a b
cborTrip @a) a
x of
    Left RoundTripFailure
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right a
_ ->
      HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
        String
"Should not have deserialized: "
          forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> String
ansiExprString (ByteString -> CBORBytes
CBORBytes (forall a. ToCBOR a => a -> ByteString
serialize' a
x))

-- | Verify that round triping through the binary form holds
roundTripExpectation ::
  (Show t, Eq t, Typeable t, HasCallStack) =>
  Trip t t ->
  t ->
  Expectation
roundTripExpectation :: forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation Trip t t
trip t
t =
  case forall t.
(Eq t, Typeable t) =>
Trip t t -> t -> Either RoundTripFailure t
roundTrip Trip t t
trip t
t of
    Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
    Right t
tDecoded -> t
tDecoded forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` t
t

roundTripCborExpectation ::
  forall t.
  (Show t, Eq t, FromCBOR t, ToCBOR t, HasCallStack) =>
  t ->
  Expectation
roundTripCborExpectation :: forall t.
(Show t, Eq t, FromCBOR t, ToCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation = forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation (forall a b. (ToCBOR a, FromCBOR b) => Trip a b
cborTrip @t)

embedTripExpectation ::
  forall a b.
  (Typeable b, Eq b, HasCallStack) =>
  Trip a b ->
  (b -> a -> Expectation) ->
  a ->
  Expectation
embedTripExpectation :: forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> (b -> a -> Expectation) -> a -> Expectation
embedTripExpectation Trip a b
trip b -> a -> Expectation
f a
t =
  case forall a b.
(Eq b, Typeable b) =>
Trip a b -> a -> Either RoundTripFailure b
embedTrip Trip a b
trip a
t of
    Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
    Right b
tDecoded -> b -> a -> Expectation
f b
tDecoded a
t

-- =====================================================================

data RoundTripFailure = RoundTripFailure
  { RoundTripFailure -> Encoding
rtfEncoding :: Encoding
  -- ^ Produced plain encoding
  , RoundTripFailure -> ByteString
rtfEncodedBytes :: BSL.ByteString
  -- ^ Serialized encoding
  , RoundTripFailure -> Maybe ByteString
rtfReEncodedBytes :: Maybe BSL.ByteString
  -- ^ Re-serialized bytes, if there was a mismatch between the binary form and the
  -- reserialization of the data type.
  , RoundTripFailure -> Maybe String
rtfFlatTermError :: Maybe String
  -- ^ Roundtripping through FlatTerm
  , RoundTripFailure -> Maybe DecoderError
rtfDecoderError :: Maybe DecoderError
  -- ^ Error received while decoding the produced bytes.
  }

instance Show RoundTripFailure where
  show :: RoundTripFailure -> String
show RoundTripFailure {Maybe String
Maybe ByteString
Maybe DecoderError
ByteString
Encoding
rtfDecoderError :: Maybe DecoderError
rtfFlatTermError :: Maybe String
rtfReEncodedBytes :: Maybe ByteString
rtfEncodedBytes :: ByteString
rtfEncoding :: Encoding
rtfDecoderError :: RoundTripFailure -> Maybe DecoderError
rtfFlatTermError :: RoundTripFailure -> Maybe String
rtfReEncodedBytes :: RoundTripFailure -> Maybe ByteString
rtfEncodedBytes :: RoundTripFailure -> ByteString
rtfEncoding :: RoundTripFailure -> Encoding
..} =
    [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      [ forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
"Decoder" Maybe DecoderError
rtfDecoderError
      , forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
"FlatTerm" Maybe String
rtfFlatTermError
      ]
        forall a. [a] -> [a] -> [a]
++ [ String
"Original did not match the reserialization (see below)."
           | Just ByteString
_ <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
rtfReEncodedBytes
           ]
        forall a. [a] -> [a] -> [a]
++ ByteString -> Maybe ByteString -> [String]
showFailedTermsWithReSerialization ByteString
rtfEncodedBytes Maybe ByteString
rtfReEncodedBytes

showMaybeDecoderError :: B.Buildable b => String -> Maybe b -> String
showMaybeDecoderError :: forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
name = \case
  Maybe b
Nothing -> String
"No " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" error"
  Just b
err -> String
name forall a. [a] -> [a] -> [a]
++ String
" error: " forall a. [a] -> [a] -> [a]
++ forall e. Buildable e => e -> String
showDecoderError b
err

showFailedTermsWithReSerialization ::
  BSL.ByteString ->
  Maybe BSL.ByteString ->
  [String]
showFailedTermsWithReSerialization :: ByteString -> Maybe ByteString -> [String]
showFailedTermsWithReSerialization ByteString
encodedBytes Maybe ByteString
mReEncodedBytes =
  case Maybe ByteString
mReEncodedBytes of
    Maybe ByteString
Nothing ->
      -- This is the usual case where re-serialization is successful
      let (Either String Term
_, [String]
origHex, [String]
origStr) = String -> ByteString -> (Either String Term, [String], [String])
termWithHex String
"Original" ByteString
encodedBytes
       in [String]
origStr forall a. [a] -> [a] -> [a]
++ [String
"OriginalHex:"] forall a. [a] -> [a] -> [a]
++ [String]
origHex
    Just ByteString
reBytes ->
      -- On a rare occasion when re-serialization does not match we try to show the
      -- diff of Hex as well as Terms
      case (String -> ByteString -> (Either String Term, [String], [String])
termWithHex String
"Original" ByteString
encodedBytes, String -> ByteString -> (Either String Term, [String], [String])
termWithHex String
"Reserialization" ByteString
reBytes) of
        ((Right Term
origTerm, [String]
origHex, [String]
_), (Right Term
reTerm, [String]
reHex, [String]
_)) ->
          [forall a. ToExpr a => a -> a -> String
diffExprString (Term
origTerm, [String]
origHex) (Term
reTerm, [String]
reHex)]
        ((Either String Term
_, [String]
origHex, [String]
origStr), (Either String Term
_, [String]
reHex, [String]
reStr)) ->
          forall a. ToExpr a => a -> a -> String
diffExprString [String]
origHex [String]
reHex forall a. a -> [a] -> [a]
: [String]
origStr forall a. Semigroup a => a -> a -> a
<> [String]
reStr
  where
    termWithHex :: String -> ByteString -> (Either String Term, [String], [String])
termWithHex String
name ByteString
lazyBytes =
      let bytes :: ByteString
bytes = ByteString -> ByteString
BSL.toStrict ByteString
lazyBytes
          decTerm :: Either String Term
decTerm = case forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder' Text
"Term" forall s. Decoder s Term
decodeTerm ByteString
bytes of
            Left DecoderError
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Could not decode as Term: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show DecoderError
err
            Right Term
term -> forall a b. b -> Either a b
Right Term
term
          hexLines :: [String]
hexLines = Int -> ByteString -> [String]
showHexBytesGrouped Int
128 ByteString
bytes
       in (Either String Term
decTerm, [String]
hexLines, [String
name forall a. Semigroup a => a -> a -> a
<> String
":", forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. ToExpr a => a -> String
ansiExprString Either String Term
decTerm])

-- | A definition of a CBOR trip through binary representation of one type to
-- another. In this module this is called an embed. When a source and target type is the
-- exact same one then it would be a dual and is expected to round trip.
data Trip a b = Trip
  { forall a b. Trip a b -> a -> Encoding
tripEncoder :: a -> Encoding
  , forall a b. Trip a b -> forall s. Decoder s b
tripDecoder :: forall s. Decoder s b
  }

cborTrip :: forall a b. (ToCBOR a, FromCBOR b) => Trip a b
cborTrip :: forall a b. (ToCBOR a, FromCBOR b) => Trip a b
cborTrip = forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
Trip forall a. ToCBOR a => a -> Encoding
toCBOR forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Construct a `Trip` using encoder and decoder, with dropper set to the decoder which
-- drops the value
mkTrip :: forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip :: forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip = forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
Trip

roundTrip :: forall t. (Eq t, Typeable t) => Trip t t -> t -> Either RoundTripFailure t
roundTrip :: forall t.
(Eq t, Typeable t) =>
Trip t t -> t -> Either RoundTripFailure t
roundTrip Trip t t
trip t
val = do
  (t
val', Encoding
encoding, ByteString
encodedBytes) <- forall a b.
Eq b =>
Text
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra (forall t. Typeable t => Text
typeLabel @t) Trip t t
trip t
val
  let reserialized :: ByteString
reserialized = forall a. ToCBOR a => a -> ByteString
serialize (forall a b. Trip a b -> a -> Encoding
tripEncoder Trip t t
trip t
val')
  if ByteString
reserialized forall a. Eq a => a -> a -> Bool
/= ByteString
encodedBytes
    then
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Encoding
encoding ByteString
encodedBytes (forall a. a -> Maybe a
Just ByteString
reserialized) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    else forall a b. b -> Either a b
Right t
val'

embedTripLabel ::
  forall a b.
  Eq b =>
  Text.Text ->
  Trip a b ->
  a ->
  Either RoundTripFailure b
embedTripLabel :: forall a b.
Eq b =>
Text -> Trip a b -> a -> Either RoundTripFailure b
embedTripLabel Text
lbl Trip a b
trip a
s =
  (\(b
val, Encoding
_, ByteString
_) -> b
val) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
Eq b =>
Text
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl Trip a b
trip a
s

embedTripLabelExtra ::
  forall a b.
  Eq b =>
  Text.Text ->
  Trip a b ->
  a ->
  Either RoundTripFailure (b, Encoding, BSL.ByteString)
embedTripLabelExtra :: forall a b.
Eq b =>
Text
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl (Trip a -> Encoding
encoder forall s. Decoder s b
decoder) a
s =
  case forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
lbl forall s. Decoder s b
decoder ByteString
encodedBytes of
    Right b
val ->
      let flatTerm :: FlatTerm
flatTerm = Encoding -> FlatTerm
CBOR.toFlatTerm Encoding
encoding
       in case forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm forall s. Decoder s b
decoder FlatTerm
flatTerm of
            Left String
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
err) forall a. Maybe a
Nothing
            Right b
valFromFlatTerm
              | b
val forall a. Eq a => a -> a -> Bool
/= b
valFromFlatTerm ->
                  let errMsg :: String
errMsg =
                        String
"Deserializoing through FlatTerm produced a different "
                          forall a. [a] -> [a] -> [a]
++ String
"value then the regular deserializer did"
                   in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
errMsg) forall a. Maybe a
Nothing
              | Bool -> Bool
not (FlatTerm -> Bool
CBOR.validFlatTerm FlatTerm
flatTerm) ->
                  let errMsg :: String
errMsg =
                        String
"Despite successful deserialization the produced "
                          forall a. [a] -> [a] -> [a]
++ String
"FlatTerm for the type is not valid"
                   in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
errMsg) forall a. Maybe a
Nothing
              | Bool
otherwise -> forall a b. b -> Either a b
Right (b
val, Encoding
encoding, ByteString
encodedBytes)
    Left DecoderError
err ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just DecoderError
err)
  where
    mkFailure :: Maybe ByteString
-> Maybe String -> Maybe DecoderError -> RoundTripFailure
mkFailure = Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Encoding
encoding ByteString
encodedBytes
    encoding :: Encoding
encoding = a -> Encoding
encoder a
s
    encodedBytes :: ByteString
encodedBytes = forall a. ToCBOR a => a -> ByteString
serialize Encoding
encoding

-- | Can we serialise a type, and then deserialise it as something else?
embedTrip ::
  forall a b.
  (Eq b, Typeable b) =>
  Trip a b ->
  a ->
  Either RoundTripFailure b
embedTrip :: forall a b.
(Eq b, Typeable b) =>
Trip a b -> a -> Either RoundTripFailure b
embedTrip = forall a b.
Eq b =>
Text -> Trip a b -> a -> Either RoundTripFailure b
embedTripLabel (String -> Text
Text.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @b)))

typeLabel :: forall t. Typeable t => Text.Text
typeLabel :: forall t. Typeable t => Text
typeLabel = String -> Text
Text.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t))