{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Golden and round-trip testing of 'DecCBOR' and 'EncCBOR' instances
module Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (
  goldenTestCBOR,
  goldenTestCBORExplicit,
  goldenTestExplicit,
  roundTripsCBORShow,
  roundTripsCBORBuildable,
  compareHexDump,
  deprecatedGoldenDecode,
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  DecoderError,
  EncCBOR (..),
  Encoding,
  Version,
  decodeFull,
  decodeFullDecoder,
  natVersion,
  serialize,
 )
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import Formatting.Buildable (Buildable (..))
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Hedgehog (
  MonadTest,
  Property,
  eval,
  property,
  success,
  tripping,
  withTests,
  (===),
 )
import Hedgehog.Internal.Property (failWith)
import Hedgehog.Internal.Show (
  LineDiff,
  lineDiff,
  mkValue,
  renderLineDiff,
  showPretty,
 )
import Test.Cardano.Prelude (
  decodeBase16,
  encodeWithIndex,
  trippingBuildable,
 )
import Text.Show.Pretty (Value (..))

byronProtVer :: Version
byronProtVer :: Version
byronProtVer = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @1

type HexDump = BSL.ByteString

type HexDumpDiff = [LineDiff]

renderHexDumpDiff :: HexDumpDiff -> [Char]
renderHexDumpDiff :: HexDumpDiff -> [Char]
renderHexDumpDiff = [[Char]] -> [Char]
Prelude.unlines ([[Char]] -> [Char])
-> (HexDumpDiff -> [[Char]]) -> HexDumpDiff -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineDiff -> [Char]) -> HexDumpDiff -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LineDiff -> [Char]
renderLineDiff

-- | Diff two 'HexDump's by comparing lines pairwise
hexDumpDiff :: HexDump -> HexDump -> Maybe HexDumpDiff
hexDumpDiff :: ByteString -> ByteString -> Maybe HexDumpDiff
hexDumpDiff ByteString
x ByteString
y = do
  [Value]
xs <- [Maybe Value] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (ByteString -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue (ByteString -> Maybe Value) -> [ByteString] -> [Maybe Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [ByteString]
BS.lines ByteString
x)
  [Value]
ys <- [Maybe Value] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (ByteString -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue (ByteString -> Maybe Value) -> [ByteString] -> [Maybe Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [ByteString]
BS.lines ByteString
y)
  HexDumpDiff -> Maybe HexDumpDiff
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HexDumpDiff -> Maybe HexDumpDiff)
-> HexDumpDiff -> Maybe HexDumpDiff
forall a b. (a -> b) -> a -> b
$
    ((Value, Value) -> HexDumpDiff) -> [(Value, Value)] -> HexDumpDiff
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Value -> Value -> HexDumpDiff) -> (Value, Value) -> HexDumpDiff
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> HexDumpDiff
lineDiff) ([(Value, Value)] -> HexDumpDiff)
-> [(Value, Value)] -> HexDumpDiff
forall a b. (a -> b) -> a -> b
$
      Value -> Value -> [Value] -> [Value] -> [(Value, Value)]
forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding
        ([Char] -> Value
String [Char]
"")
        ([Char] -> Value
String [Char]
"")
        [Value]
xs
        [Value]
ys

zipWithPadding :: a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding :: forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding a
a b
b (a
x : [a]
xs) (b
y : [b]
ys) = (a
x, b
y) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: a -> b -> [a] -> [b] -> [(a, b)]
forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipWithPadding a
a b
b [a]
xs [b]
ys
zipWithPadding a
a b
_ [] [b]
ys = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (a -> [a]
forall a. a -> [a]
repeat a
a) [b]
ys
zipWithPadding a
_ b
b [a]
xs [] = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs (b -> [b]
forall a. a -> [a]
repeat b
b)

-- | A custom version of '(===)' for 'HexDump's to get prettier diffs
compareHexDump :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m ()
compareHexDump :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
compareHexDump ByteString
x ByteString
y = do
  Bool
ok <- (HasCallStack => m Bool) -> m Bool
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m Bool) -> m Bool)
-> (HasCallStack => m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> m Bool
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
eval (ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
y)
  if Bool
ok then m ()
forall (m :: * -> *). MonadTest m => m ()
success else (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
failHexDumpDiff ByteString
x ByteString
y

-- | Fail with a nice line diff of the two HexDumps
failHexDumpDiff :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m ()
failHexDumpDiff :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
failHexDumpDiff ByteString
x ByteString
y = case ByteString -> ByteString -> Maybe HexDumpDiff
hexDumpDiff ByteString
x ByteString
y of
  Maybe HexDumpDiff
Nothing ->
    (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      Maybe Diff -> [Char] -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
Prelude.unlines
          [[Char]
"━━━ Not Equal ━━━", ByteString -> [Char]
forall a. Show a => a -> [Char]
showPretty ByteString
x, ByteString -> [Char]
forall a. Show a => a -> [Char]
showPretty ByteString
y]
  Just HexDumpDiff
dif -> (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Diff -> [Char] -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ HexDumpDiff -> [Char]
renderHexDumpDiff HexDumpDiff
dif

-- | Check that the 'encode' and 'decode' function of the 'Bi' instances work as
-- expected w.r.t. the give reference data, this is, given a value @x::a@, and
-- a file path @fp@:
--
-- - The encoded data should coincide with the contents of the @fp@.
-- - Decoding @fp@ should give as a result @x@
goldenTestCBOR ::
  forall a.
  (DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
  a ->
  FilePath ->
  Property
goldenTestCBOR :: forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> [Char] -> Property
goldenTestCBOR =
  (HasCallStack => a -> [Char] -> Property)
-> a -> [Char] -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a -> [Char] -> Property)
 -> a -> [Char] -> Property)
-> (HasCallStack => a -> [Char] -> Property)
-> a
-> [Char]
-> Property
forall a b. (a -> b) -> a -> b
$
    Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> [Char]
-> Property
forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> [Char]
-> Property
goldenTestCBORExplicit (Proxy a -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) a -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Decoder s a
forall s. Decoder s a
forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Variant of 'goldenTestBi' using custom encode and decode functions.
--
-- This is required for the encode/decode golden-tests for types that do no
-- have a 'Bi' instance.
goldenTestCBORExplicit ::
  forall a.
  (Eq a, Show a, HasCallStack) =>
  -- | Label for error reporting when decoding.
  Text ->
  (a -> Encoding) ->
  (forall s. Decoder s a) ->
  a ->
  FilePath ->
  Property
goldenTestCBORExplicit :: forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> [Char]
-> Property
goldenTestCBORExplicit Text
eLabel a -> Encoding
enc forall s. Decoder s a
dec =
  (a -> ByteString)
-> (ByteString -> Either DecoderError a) -> a -> [Char] -> Property
forall a.
(Eq a, Show a, HasCallStack) =>
(a -> ByteString)
-> (ByteString -> Either DecoderError a) -> a -> [Char] -> Property
goldenTestExplicit (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer (Encoding -> ByteString) -> (a -> Encoding) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
enc) ByteString -> Either DecoderError a
fullDecoder
  where
    fullDecoder :: BSL.ByteString -> Either DecoderError a
    fullDecoder :: ByteString -> Either DecoderError a
fullDecoder = Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
eLabel Decoder s a
forall s. Decoder s a
dec

goldenTestExplicit ::
  forall a.
  (Eq a, Show a, HasCallStack) =>
  (a -> BS.ByteString) ->
  (BS.ByteString -> Either DecoderError a) ->
  a ->
  FilePath ->
  Property
goldenTestExplicit :: forall a.
(Eq a, Show a, HasCallStack) =>
(a -> ByteString)
-> (ByteString -> Either DecoderError a) -> a -> [Char] -> Property
goldenTestExplicit a -> ByteString
encode ByteString -> Either DecoderError a
decode a
x [Char]
path = (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
  let bs' :: ByteString
bs' = ByteString -> ByteString
encodeWithIndex (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
encode (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ a
x
  TestLimit -> Property -> Property
withTests TestLimit
1 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- IO ByteString -> PropertyT IO ByteString
forall a. IO a -> PropertyT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> PropertyT IO ByteString)
-> IO ByteString -> PropertyT IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    let target :: Maybe ByteString
target = ByteString -> Maybe ByteString
decodeBase16 ByteString
bs
    ByteString -> ByteString -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
ByteString -> ByteString -> m ()
compareHexDump ByteString
bs ByteString
bs'
    (ByteString -> Either DecoderError a)
-> Maybe ByteString -> Maybe (Either DecoderError a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either DecoderError a
decode Maybe ByteString
target Maybe (Either DecoderError a)
-> Maybe (Either DecoderError a) -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Either DecoderError a -> Maybe (Either DecoderError a)
forall a. a -> Maybe a
Just (a -> Either DecoderError a
forall a b. b -> Either a b
Right a
x)

-- | Round trip test a value (any instance of 'DecCBOR', 'EncCBOR', and 'Show'
--   classes) by serializing it to a ByteString and back again and that also has
--   a 'Show' instance. If the 'a' type has both 'Show' and 'Buildable'
--   instances, it's best to use this version.
roundTripsCBORShow ::
  (DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
  a ->
  m ()
roundTripsCBORShow :: forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow a
x =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ a
-> (a -> ByteString)
-> (ByteString -> Either DecoderError a)
-> m ()
forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping a
x (Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer) (Version -> ByteString -> Either DecoderError a
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
byronProtVer)

-- | Round trip (via ByteString) any instance of the 'DecCBOR' and 'EncCBOR'
--   class that also has a 'Buildable' instance.
roundTripsCBORBuildable ::
  (DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a, HasCallStack) =>
  a ->
  m ()
roundTripsCBORBuildable :: forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable a
a =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ a
-> (a -> ByteString)
-> (ByteString -> Either DecoderError a)
-> m ()
forall (f :: * -> *) a b (m :: * -> *).
(HasCallStack, Buildable (f a), Eq (f a), Show b, Applicative f,
 MonadTest m) =>
a -> (a -> b) -> (b -> f a) -> m ()
trippingBuildable a
a (Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer) (Version -> ByteString -> Either DecoderError a
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
byronProtVer)

deprecatedGoldenDecode ::
  HasCallStack => Text -> (forall s. Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode :: HasCallStack =>
Text -> (forall s. Decoder s ()) -> [Char] -> Property
deprecatedGoldenDecode Text
lbl forall s. Decoder s ()
decoder [Char]
path =
  (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$ TestLimit -> Property -> Property
withTests TestLimit
1 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
bs <- ByteString -> Maybe ByteString
decodeBase16 (ByteString -> Maybe ByteString)
-> PropertyT IO ByteString -> PropertyT IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> PropertyT IO ByteString
forall a. IO a -> PropertyT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ByteString
BS.readFile [Char]
path)
    (ByteString -> Either DecoderError ())
-> Maybe ByteString -> Maybe (Either DecoderError ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version
-> Text
-> (forall s. Decoder s ())
-> ByteString
-> Either DecoderError ()
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
lbl Decoder s ()
forall s. Decoder s ()
decoder) Maybe ByteString
bs Maybe (Either DecoderError ())
-> Maybe (Either DecoderError ()) -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Either DecoderError () -> Maybe (Either DecoderError ())
forall a. a -> Maybe a
Just (() -> Either DecoderError ()
forall a b. b -> Either a b
Right ())