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

module Test.Cardano.Binary.Helpers (
  -- * Binary test helpers
  U,
  U24,
  extensionProperty,
  cborFlatTermValid,

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

import Codec.CBOR.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 Numeric.Natural (Natural)

import Hedgehog (annotate, failure, forAllWith, success)
import qualified Hedgehog as HH
import qualified Hedgehog.Gen as HH.Gen
import Test.Hspec ()
import Test.Hspec.QuickCheck ()
import Test.QuickCheck (
  Arbitrary (arbitrary),
  Gen,
  Property,
  choose,
  forAll,
  property,
  (===),
 )
import Test.QuickCheck.Instances ()

import Cardano.Binary (
  FromCBOR (..),
  Range (..),
  Size,
  SizeOverride (..),
  ToCBOR (..),
  decodeListLenOf,
  decodeNestedCborBytes,
  encodeListLen,
  encodeNestedCborBytes,
  serialize,
  szSimplify,
  szWithCtx,
  unsafeDeserialize,
 )

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

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

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

-- 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [U] -> ShowS
$cshowList :: [U] -> ShowS
show :: U -> String
$cshow :: U -> String
showsPrec :: Int -> U -> ShowS
$cshowsPrec :: Int -> U -> ShowS
Show, U -> U -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: U -> U -> Bool
$c/= :: U -> U -> Bool
== :: U -> U -> Bool
$c== :: U -> U -> Bool
Eq)

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

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

instance Arbitrary U where
  arbitrary :: Gen U
arbitrary = Word8 -> ByteString -> U
U forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Word8
0, Word8
255) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [U24] -> ShowS
$cshowList :: [U24] -> ShowS
show :: U24 -> String
$cshow :: U24 -> String
showsPrec :: Int -> U24 -> ShowS
$cshowsPrec :: Int -> U24 -> ShowS
Show, U24 -> U24 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: U24 -> U24 -> Bool
$c/= :: U24 -> U24 -> Bool
== :: U24 -> U24 -> Bool
$c== :: U24 -> U24 -> Bool
Eq)

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

instance ToCBOR U24 where
  toCBOR :: U24 -> Encoding
toCBOR (U24 Word8
word8 ByteString
bs) =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
word8 :: Word8)
      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, FromCBOR a, ToCBOR a) => Property
extensionProperty :: forall a.
(Arbitrary a, Eq a, Show a, FromCBOR a, ToCBOR a) =>
Property
extensionProperty = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll @a (forall a. Arbitrary a => Gen a
arbitrary :: Gen a) 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 = forall a. ToCBOR a => a -> ByteString
serialize a
input -- Step 1
    (U
u :: U) = forall a. FromCBOR a => ByteString -> a
unsafeDeserialize ByteString
serialized -- Step 2
    (a
encoded :: a) = forall a. FromCBOR a => ByteString -> a
unsafeDeserialize (forall a. ToCBOR a => a -> ByteString
serialize U
u) -- Step 3
   in
    a
encoded 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Format Builder a -> a
bprint 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 = forall a. Buildable a => a -> String
bshow
    , gen :: Gen a
gen = forall (m :: * -> *) a. MonadGen m => m a
HH.Gen.discard
    , precise :: Bool
precise = Bool
False
    , addlCtx :: Map TypeRep SizeOverride
addlCtx = forall k a. Map k a
M.empty
    , computedCtx :: a -> Map TypeRep SizeOverride
computedCtx = forall a b. a -> b -> a
const 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 = forall a. Show a => a -> String
show
    , gen :: Gen a
gen = forall (m :: * -> *) a. MonadGen m => m a
HH.Gen.discard
    , precise :: Bool
precise = Bool
False
    , addlCtx :: Map TypeRep SizeOverride
addlCtx = forall k a. Map k a
M.empty
    , computedCtx :: a -> Map TypeRep SizeOverride
computedCtx = forall a b. a -> b -> a
const forall k a. Map k a
M.empty
    }

-- | Create a test case from the given test configuration.
sizeTest :: forall a. ToCBOR a => SizeTestConfig a -> HH.Property
sizeTest :: forall a. ToCBOR a => SizeTestConfig a -> Property
sizeTest SizeTestConfig {Bool
Map TypeRep SizeOverride
Gen a
a -> String
a -> Map TypeRep SizeOverride
computedCtx :: a -> Map TypeRep SizeOverride
addlCtx :: Map TypeRep SizeOverride
precise :: Bool
gen :: Gen a
debug :: a -> String
computedCtx :: forall a. SizeTestConfig a -> a -> Map TypeRep SizeOverride
addlCtx :: forall a. SizeTestConfig a -> Map TypeRep SizeOverride
precise :: forall a. SizeTestConfig a -> Bool
gen :: forall a. SizeTestConfig a -> Gen a
debug :: forall a. SizeTestConfig a -> a -> String
..} = HasCallStack => PropertyT IO () -> Property
HH.property forall a b. (a -> b) -> a -> b
$ do
  a
x <- 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 = 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
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Computed bounds: " forall a. Semigroup a => a -> a -> a
<> forall a. Buildable a => a -> String
bshow Range Natural
bounds)
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Actual size:     " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Natural
sz)
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Value: " forall a. Semigroup a => a -> a -> a
<> a -> String
debug a
x)

  case forall a.
ToCBOR a =>
Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify Map TypeRep SizeOverride
ctx a
x of
    ComparisonResult
Exact -> forall (m :: * -> *). MonadTest m => m ()
success
    WithinBounds Natural
_ Range Natural
_ | Bool -> Bool
not Bool
precise -> forall (m :: * -> *). MonadTest m => m ()
success
    WithinBounds Natural
sz Range Natural
bounds -> do
      Natural -> Range Natural -> PropertyT IO ()
badBounds Natural
sz Range Natural
bounds
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"Bounds were not exact."
      forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
    BoundsAreSymbolic Size
bounds -> do
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate (String
"Bounds are symbolic: " forall a. Semigroup a => a -> a -> a
<> forall a. Buildable a => a -> String
bshow Size
bounds)
      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
      forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate String
"Size fell outside of bounds."
      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 @ToCBOR a@, check that the encoded size
--   of @x@ falls within the statically-computed size range for @a@.
szVerify :: ToCBOR a => M.Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify :: forall a.
ToCBOR a =>
Map TypeRep SizeOverride -> a -> ComparisonResult
szVerify Map TypeRep SizeOverride
ctx a
x = case Size -> Either Size (Range Natural)
szSimplify (forall a. ToCBOR a => Map TypeRep SizeOverride -> Proxy a -> Size
szWithCtx Map TypeRep SizeOverride
ctx (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)) of
  Left Size
bounds -> Size -> ComparisonResult
BoundsAreSymbolic Size
bounds
  Right Range Natural
range
    | forall b. Range b -> b
lo Range Natural
range forall a. Ord a => a -> a -> Bool
<= Natural
sz Bool -> Bool -> Bool
&& Natural
sz forall a. Ord a => a -> a -> Bool
<= forall b. Range b -> b
hi Range Natural
range ->
        if forall b. Range b -> b
lo Range Natural
range forall a. Eq a => a -> a -> Bool
== 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length forall a b. (a -> b) -> a -> b
$ forall a. ToCBOR a => a -> ByteString
serialize a
x