{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Binary.Vintage.Helpers (
  byronProtVer,

  -- * Binary test helpers
  U,
  U24,
  extensionProperty,
  cborFlatTermValid,

  -- * Static size estimates
  SizeTestConfig (..),
  cfg,
  scfg,
  sizeTest,
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  Range (..),
  Size,
  SizeOverride (..),
  byronProtVer,
  decodeListLenOf,
  decodeNestedCborBytes,
  encodeListLen,
  encodeNestedCborBytes,
  serialize,
  szSimplify,
  szWithCtx,
  unsafeDeserialize,
 )
import Cardano.Ledger.Binary.FlatTerm (toFlatTerm, validFlatTerm)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as M
import Data.Text.Lazy (unpack)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Typeable (TypeRep)
import Data.Word (Word8)
import Formatting (Buildable, bprint, build)
import Hedgehog (annotate, failure, forAllWith, success)
import qualified Hedgehog as HH
import qualified Hedgehog.Gen as HH.Gen
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Binary.Arbitrary ()
import Test.Hspec ()
import Test.Hspec.QuickCheck ()
import Test.QuickCheck (
  Arbitrary (arbitrary),
  Gen,
  Property,
  choose,
  forAll,
  property,
  (===),
 )

--------------------------------------------------------------------------------
-- From/to tests
--------------------------------------------------------------------------------

-- | Machinery to test we perform "flat" encoding.
cborFlatTermValid :: EncCBOR a => a -> Property
cborFlatTermValid :: forall a. EncCBOR a => a -> Property
cborFlatTermValid = Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> (a -> Bool) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatTerm -> Bool
validFlatTerm (FlatTerm -> Bool) -> (a -> FlatTerm) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Encoding -> FlatTerm
toFlatTerm Version
byronProtVer (Encoding -> FlatTerm) -> (a -> Encoding) -> a -> FlatTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR

--------------------------------------------------------------------------------

-- Type to be used to simulate a breaking change in the serialisation
-- schema, so we can test instances which uses the `UnknownXX` pattern
-- for extensibility.
-- Check the `extensionProperty` for more details.
data U = U Word8 BS.ByteString deriving (Int -> U -> ShowS
[U] -> ShowS
U -> String
(Int -> U -> ShowS) -> (U -> String) -> ([U] -> ShowS) -> Show U
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> U -> ShowS
showsPrec :: Int -> U -> ShowS
$cshow :: U -> String
show :: U -> String
$cshowList :: [U] -> ShowS
showList :: [U] -> ShowS
Show, U -> U -> Bool
(U -> U -> Bool) -> (U -> U -> Bool) -> Eq U
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: U -> U -> Bool
== :: U -> U -> Bool
$c/= :: U -> U -> Bool
/= :: U -> U -> Bool
Eq)

instance EncCBOR U where
  encCBOR :: U -> Encoding
encCBOR (U Word8
word8 ByteString
bs) =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
word8 :: Word8)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeNestedCborBytes
        (ByteString -> ByteString
LBS.fromStrict ByteString
bs)

instance DecCBOR U where
  decCBOR :: forall s. Decoder s U
decCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    Word8 -> ByteString -> U
U (Word8 -> ByteString -> U)
-> Decoder s Word8 -> Decoder s (ByteString -> U)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word8
forall s. Decoder s Word8
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (ByteString -> U) -> Decoder s ByteString -> Decoder s U
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ByteString
forall s. Decoder s ByteString
decodeNestedCborBytes

instance Arbitrary U where
  arbitrary :: Gen U
arbitrary = Word8 -> ByteString -> U
U (Word8 -> ByteString -> U) -> Gen Word8 -> Gen (ByteString -> U)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8, Word8) -> Gen Word8
forall a. Random a => (a, a) -> Gen a
choose (Word8
0, Word8
255) Gen (ByteString -> U) -> Gen ByteString -> Gen U
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary

-- | Like `U`, but we expect to read back the Cbor Data Item when decoding.
data U24 = U24 Word8 BS.ByteString deriving (Int -> U24 -> ShowS
[U24] -> ShowS
U24 -> String
(Int -> U24 -> ShowS)
-> (U24 -> String) -> ([U24] -> ShowS) -> Show U24
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> U24 -> ShowS
showsPrec :: Int -> U24 -> ShowS
$cshow :: U24 -> String
show :: U24 -> String
$cshowList :: [U24] -> ShowS
showList :: [U24] -> ShowS
Show, U24 -> U24 -> Bool
(U24 -> U24 -> Bool) -> (U24 -> U24 -> Bool) -> Eq U24
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: U24 -> U24 -> Bool
== :: U24 -> U24 -> Bool
$c/= :: U24 -> U24 -> Bool
/= :: U24 -> U24 -> Bool
Eq)

instance DecCBOR U24 where
  decCBOR :: forall s. Decoder s U24
decCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    Word8 -> ByteString -> U24
U24 (Word8 -> ByteString -> U24)
-> Decoder s Word8 -> Decoder s (ByteString -> U24)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word8
forall s. Decoder s Word8
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (ByteString -> U24)
-> Decoder s ByteString -> Decoder s U24
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ByteString
forall s. Decoder s ByteString
decodeNestedCborBytes

instance EncCBOR U24 where
  encCBOR :: U24 -> Encoding
encCBOR (U24 Word8
word8 ByteString
bs) =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
word8 :: Word8)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeNestedCborBytes
        (ByteString -> ByteString
LBS.fromStrict ByteString
bs)

-- | Given a data type which can be extended, verify we can indeed do so
-- without breaking anything. This should work with every time which adopted
-- the schema of having at least one constructor of the form:
-- .... | Unknown Word8 ByteString
extensionProperty ::
  forall a. (Arbitrary a, Eq a, Show a, DecCBOR a, EncCBOR a) => Property
extensionProperty :: forall a.
(Arbitrary a, Eq a, Show a, DecCBOR a, EncCBOR a) =>
Property
extensionProperty = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll @a (Gen a
forall a. Arbitrary a => Gen a
arbitrary :: Gen a) ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \a
input ->
  {- This function works as follows:

     1. When we call `serialized`, we are implicitly assuming (as contract of this
        function) that the input type would be of a shape such as:

        data MyType = Constructor1 Int Bool
                    | Constructor2 String
                    | UnknownConstructor Word8 ByteString

        Such type will be encoded, roughly, like this:

        encode (Constructor1 a b) = encodeWord 0 <> encodeNestedCbor (a,b)
        encode (Constructor2 a b) = encodeWord 1 <> encodeNestedCbor a
        encode (UnknownConstructor tag bs) = encodeWord tag <> encodeNestedCborBytes bs

        In CBOR terms, we would produce something like this:

        <tag :: Word32><Tag24><CborDataItem :: ByteString>

     2. Now, when we call `unsafeDeserialize serialized`, we are effectively asking to produce as
        output a value of type `U`. `U` is defined by only 1 constructor, it
        being `U Word8 ByteString`, but this is still compatible with our `tag + cborDataItem`
        format. So now we will have something like:

        U <tag :: Word32> <CborDataItem :: ByteString>

        (The <Tag24> has been removed as part of the decoding process).

     3. We now call `unsafeDeserialize (serialize u)`, which means: Can you produce a CBOR binary
        from `U`, and finally try to decode it into a value of type `a`? This will work because
        our intermediate encoding into `U` didn't touch the inital `<tag :: Word32>`, so we will
        be able to reconstruct the original object back.
        More specifically, `serialize u` would produce once again:

        <tag :: Word32><Tag24><CborDataItem :: ByteString>

        (The <Tag24> has been added as part of the encoding process).

        `unsafeDeserialize` would then consume the tag (to understand which type constructor this corresponds to),
        remove the <Tag24> token and finally proceed to deserialise the rest.

  -}
  let serialized :: ByteString
serialized = Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer a
input -- Step 1
      (U
u :: U) = Version -> ByteString -> U
forall a. DecCBOR a => Version -> ByteString -> a
unsafeDeserialize Version
byronProtVer ByteString
serialized -- Step 2
      (a
encoded :: a) = Version -> ByteString -> a
forall a. DecCBOR a => Version -> ByteString -> a
unsafeDeserialize Version
byronProtVer (Version -> U -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer U
u) -- Step 3
   in a
encoded a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a
input

--------------------------------------------------------------------------------
-- Static size estimates
--------------------------------------------------------------------------------

bshow :: Buildable a => a -> String
bshow :: forall a. Buildable a => a -> String
bshow = Text -> String
unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bprint Format Builder (a -> Builder)
forall a r. Buildable a => Format r (a -> r)
build

-- | Configuration for a single test case.
data SizeTestConfig a = SizeTestConfig
  { forall a. SizeTestConfig a -> a -> String
debug :: a -> String
  -- ^ Pretty-print values
  , forall a. SizeTestConfig a -> Gen a
gen :: HH.Gen a
  -- ^ Generator
  , forall a. SizeTestConfig a -> Bool
precise :: Bool
  -- ^ Must estimates be exact?
  , forall a. SizeTestConfig a -> Map TypeRep SizeOverride
addlCtx :: M.Map TypeRep SizeOverride
  -- ^ Additional size overrides
  , forall a. SizeTestConfig a -> a -> Map TypeRep SizeOverride
computedCtx :: a -> M.Map TypeRep SizeOverride
  -- ^ Size overrides computed from a concrete instance.
  }

-- | Default configuration, for @Buildable@ types.
cfg :: Buildable a => SizeTestConfig a
cfg :: forall a. Buildable a => SizeTestConfig a
cfg =
  SizeTestConfig
    { debug :: a -> String
debug = a -> String
forall a. Buildable a => a -> String
bshow
    , gen :: Gen a
gen = Gen a
forall (m :: * -> *) a. MonadGen m => m a
HH.Gen.discard
    , precise :: Bool
precise = Bool
False
    , addlCtx :: Map TypeRep SizeOverride
addlCtx = Map TypeRep SizeOverride
forall k a. Map k a
M.empty
    , computedCtx :: a -> Map TypeRep SizeOverride
computedCtx = Map TypeRep SizeOverride -> a -> Map TypeRep SizeOverride
forall a b. a -> b -> a
const Map TypeRep SizeOverride
forall k a. Map k a
M.empty
    }

-- | Default configuration, for @Show@able types.
scfg :: Show a => SizeTestConfig a
scfg :: forall a. Show a => SizeTestConfig a
scfg =
  SizeTestConfig
    { debug :: a -> String
debug = a -> String
forall a. Show a => a -> String
show
    , gen :: Gen a
gen = Gen a
forall (m :: * -> *) a. MonadGen m => m a
HH.Gen.discard
    , precise :: Bool
precise = Bool
False
    , addlCtx :: Map TypeRep SizeOverride
addlCtx = Map TypeRep SizeOverride
forall k a. Map k a
M.empty
    , computedCtx :: a -> Map TypeRep SizeOverride
computedCtx = Map TypeRep SizeOverride -> a -> Map TypeRep SizeOverride
forall a b. a -> b -> a
const Map TypeRep SizeOverride
forall k a. Map k a
M.empty
    }

-- | Create a test case from the given test configuration.
sizeTest :: forall a. EncCBOR a => SizeTestConfig a -> HH.Property
sizeTest :: forall a. EncCBOR a => SizeTestConfig a -> Property
sizeTest SizeTestConfig {Bool
Map TypeRep SizeOverride
Gen a
a -> String
a -> Map TypeRep SizeOverride
debug :: forall a. SizeTestConfig a -> a -> String
gen :: forall a. SizeTestConfig a -> Gen a
precise :: forall a. SizeTestConfig a -> Bool
addlCtx :: forall a. SizeTestConfig a -> Map TypeRep SizeOverride
computedCtx :: forall a. SizeTestConfig a -> a -> Map TypeRep SizeOverride
debug :: a -> String
gen :: Gen a
precise :: Bool
addlCtx :: Map TypeRep SizeOverride
computedCtx :: a -> Map TypeRep SizeOverride
..} = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
HH.property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  a
x <- (a -> String) -> Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, HasCallStack) =>
(a -> String) -> Gen a -> PropertyT m a
forAllWith a -> String
debug Gen a
gen

  let ctx :: Map TypeRep SizeOverride
ctx = Map TypeRep SizeOverride
-> Map TypeRep SizeOverride -> Map TypeRep SizeOverride
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (a -> Map TypeRep SizeOverride
computedCtx a
x) Map TypeRep SizeOverride
addlCtx

      badBounds :: Natural -> Range Natural -> HH.PropertyT IO ()
      badBounds :: Natural -> Range Natural -> PropertyT IO ()
badBounds Natural
sz Range Natural
bounds = do
        String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Computed bounds: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Range Natural -> String
forall a. Buildable a => a -> String
bshow Range Natural
bounds)
        String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Actual size:     " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
sz)
        String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Value: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
debug a
x)

  case Map TypeRep SizeOverride -> a -> ComparisonResult
forall a.
EncCBOR a =>
Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify Map TypeRep SizeOverride
ctx a
x of
    ComparisonResult
Exact -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success
    WithinBounds Natural
_ Range Natural
_ | Bool -> Bool
not Bool
precise -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success
    WithinBounds Natural
sz Range Natural
bounds -> do
      Natural -> Range Natural -> PropertyT IO ()
badBounds Natural
sz Range Natural
bounds
      String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"Bounds were not exact."
      PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
    BoundsAreSymbolic Size
bounds -> do
      String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Bounds are symbolic: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Size -> String
forall a. Buildable a => a -> String
bshow Size
bounds)
      PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
    OutOfBounds Natural
sz Range Natural
bounds -> do
      Natural -> Range Natural -> PropertyT IO ()
badBounds Natural
sz Range Natural
bounds
      String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"Size fell outside of bounds."
      PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure

-- | The possible results from @szVerify@, describing various ways
--   a size can or cannot be found within a certain range.
data ComparisonResult
  = -- | Size matched the bounds, and the bounds were exact.
    Exact
  | -- | Size matched the bounds, but the bounds are not exact.
    WithinBounds Natural (Range Natural)
  | -- | The bounds could not be reduced to a numerical range.
    BoundsAreSymbolic Size
  | -- | The size fell outside of the bounds.
    OutOfBounds Natural (Range Natural)

-- | For a given value @x :: a@ with @EncCBOR a@, check that the encoded size
--   of @x@ falls within the statically-computed size range for @a@.
szVerify :: EncCBOR a => M.Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify :: forall a.
EncCBOR a =>
Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify Map TypeRep SizeOverride
ctx a
x = case Size -> Either Size (Range Natural)
szSimplify (Map TypeRep SizeOverride -> Proxy a -> Size
forall a. EncCBOR a => Map TypeRep SizeOverride -> Proxy a -> Size
szWithCtx Map TypeRep SizeOverride
ctx (a -> Proxy a
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)) of
  Left Size
bounds -> Size -> ComparisonResult
BoundsAreSymbolic Size
bounds
  Right Range Natural
range
    | Range Natural -> Natural
forall b. Range b -> b
lo Range Natural
range Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
sz Bool -> Bool -> Bool
&& Natural
sz Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Range Natural -> Natural
forall b. Range b -> b
hi Range Natural
range ->
        if Range Natural -> Natural
forall b. Range b -> b
lo Range Natural
range Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Range Natural -> Natural
forall b. Range b -> b
hi Range Natural
range then ComparisonResult
Exact else Natural -> Range Natural -> ComparisonResult
WithinBounds Natural
sz Range Natural
range
  Right Range Natural
range -> Natural -> Range Natural -> ComparisonResult
OutOfBounds Natural
sz Range Natural
range
  where
    sz :: Natural
    sz :: Natural
sz = Int64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Natural) -> Int64 -> Natural
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer a
x