{-# 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,
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  byronProtVer,
  decodeListLenOf,
  decodeNestedCborBytes,
  encodeListLen,
  encodeNestedCborBytes,
  serialize,
  unsafeDeserialize,
 )
import Cardano.Ledger.Binary.FlatTerm (toFlatTerm, validFlatTerm)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Word (Word8)
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