{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Chain.MempoolPayload.CBOR (
  tests,
) where

import Cardano.Ledger.Binary (
  ByteSpan,
  DecCBOR (..),
  Decoder,
  EncCBOR,
  byronProtVer,
  decCBOR,
  decodeFull,
  decodeFullDecoder,
  encCBOR,
  serialize,
  slice,
 )
import Cardano.Prelude
import qualified Data.ByteString.Lazy as LBS
import Hedgehog (Property, tripping)
import Test.Cardano.Chain.MempoolPayload.Example (
  exampleMempoolPayload,
  exampleMempoolPayload1,
  exampleMempoolPayload2,
  exampleMempoolPayload3,
 )
import Test.Cardano.Chain.MempoolPayload.Gen (genMempoolPayload)
import Test.Cardano.Crypto.Gen (feedPM)
import Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (
  goldenTestCBOR,
  goldenTestCBORExplicit,
  roundTripsCBORShow,
 )
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, eachOfTS)

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

-- | Serialises @f ()@ and uses that 'ByteString' as the annotation to splice
-- in.
fillInByteString ::
  forall f.
  (DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
  f () ->
  f ByteString
fillInByteString :: forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString f ()
a =
  (DecoderError -> f ByteString)
-> (f ByteString -> f ByteString)
-> Either DecoderError (f ByteString)
-> f ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> f ByteString
forall a. HasCallStack => Text -> a
panic (Text -> f ByteString)
-> (DecoderError -> Text) -> DecoderError -> f ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DecoderError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show) f ByteString -> f ByteString
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (Either DecoderError (f ByteString) -> f ByteString)
-> Either DecoderError (f ByteString) -> f ByteString
forall a b. (a -> b) -> a -> b
$ Version
-> Text
-> (forall s. Decoder s (f ByteString))
-> ByteString
-> Either DecoderError (f ByteString)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
forall a. Monoid a => a
mempty Decoder s (f ByteString)
forall s. Decoder s (f ByteString)
dec ByteString
bytes
  where
    bytes :: LByteString
    bytes :: ByteString
bytes = Version -> f () -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer f ()
a

    dec :: Decoder s (f ByteString)
    dec :: forall s. Decoder s (f ByteString)
dec = (ByteSpan -> ByteString) -> f ByteSpan -> f ByteString
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
slice ByteString
bytes) (f ByteSpan -> f ByteString)
-> Decoder s (f ByteSpan) -> Decoder s (f ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f ByteSpan)
forall s. Decoder s (f ByteSpan)
forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Variant of 'goldenTestCBOR' that does not use the @'EncCBOR' (f ())@
-- instance, but the @'EncCBOR' (f ByteString)@ instance. The latter instance
-- allows reusing the annotation when serialising instead of reserialising
-- from scratch.
filledInGoldenTestCBOR ::
  forall f.
  ( DecCBOR (f ())
  , EncCBOR (f ())
  , DecCBOR (f ByteSpan)
  , EncCBOR (f ByteString)
  , Functor f
  , Eq (f ())
  , Show (f ())
  , HasCallStack
  ) =>
  f () ->
  FilePath ->
  Property
filledInGoldenTestCBOR :: forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR =
  Text
-> (f () -> Encoding)
-> (forall s. Decoder s (f ()))
-> f ()
-> String
-> Property
forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> String
-> Property
goldenTestCBORExplicit
    (Proxy (f ()) -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy (f ()) -> Text) -> Proxy (f ()) -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(f ()))
    (f ByteString -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (f ByteString -> Encoding)
-> (f () -> f ByteString) -> f () -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f () -> f ByteString
forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString)
    Decoder s (f ())
forall s. Decoder s (f ())
forall a s. DecCBOR a => Decoder s a
decCBOR

--------------------------------------------------------------------------------
-- MempoolPayload
--------------------------------------------------------------------------------

goldenMempoolPayload :: Property
goldenMempoolPayload :: Property
goldenMempoolPayload =
  MempoolPayload -> String -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload
    String
"golden/cbor/mempoolpayload/MempoolPayload"

goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayloadFilledIn =
  MempoolPayload -> String -> Property
forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload
    String
"golden/cbor/mempoolpayload/MempoolPayload"

goldenMempoolPayload1 :: Property
goldenMempoolPayload1 :: Property
goldenMempoolPayload1 =
  MempoolPayload -> String -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload1
    String
"golden/cbor/mempoolpayload/MempoolPayload1"

goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload1FilledIn =
  MempoolPayload -> String -> Property
forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload1
    String
"golden/cbor/mempoolpayload/MempoolPayload1"

goldenMempoolPayload2 :: Property
goldenMempoolPayload2 :: Property
goldenMempoolPayload2 =
  MempoolPayload -> String -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload2
    String
"golden/cbor/mempoolpayload/MempoolPayload2"

goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload2FilledIn =
  MempoolPayload -> String -> Property
forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload2
    String
"golden/cbor/mempoolpayload/MempoolPayload2"

goldenMempoolPayload3 :: Property
goldenMempoolPayload3 :: Property
goldenMempoolPayload3 =
  MempoolPayload -> String -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload3
    String
"golden/cbor/mempoolpayload/MempoolPayload3"

goldenMempoolPayload3FilledIn :: Property
goldenMempoolPayload3FilledIn :: Property
goldenMempoolPayload3FilledIn =
  MempoolPayload -> String -> Property
forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload3
    String
"golden/cbor/mempoolpayload/MempoolPayload3"

ts_roundTripMempoolPayload :: TSProperty
ts_roundTripMempoolPayload :: TSProperty
ts_roundTripMempoolPayload =
  TestLimit
-> Gen MempoolPayload
-> (MempoolPayload -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
200 ((ProtocolMagicId -> Gen MempoolPayload) -> Gen MempoolPayload
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen MempoolPayload
genMempoolPayload) MempoolPayload -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

ts_roundTripMempoolPayloadFilledIn :: TSProperty
ts_roundTripMempoolPayloadFilledIn :: TSProperty
ts_roundTripMempoolPayloadFilledIn =
  TestLimit
-> Gen MempoolPayload
-> (MempoolPayload -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
200 ((ProtocolMagicId -> Gen MempoolPayload) -> Gen MempoolPayload
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen MempoolPayload
genMempoolPayload) ((MempoolPayload -> PropertyT IO ()) -> TSProperty)
-> (MempoolPayload -> PropertyT IO ()) -> TSProperty
forall a b. (a -> b) -> a -> b
$ \MempoolPayload
x ->
    MempoolPayload
-> (MempoolPayload -> ByteString)
-> (ByteString -> Either DecoderError MempoolPayload)
-> PropertyT IO ()
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 MempoolPayload
x (Version -> AMempoolPayload ByteString -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer (AMempoolPayload ByteString -> ByteString)
-> (MempoolPayload -> AMempoolPayload ByteString)
-> MempoolPayload
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MempoolPayload -> AMempoolPayload ByteString
forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString) (Version -> ByteString -> Either DecoderError MempoolPayload
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
byronProtVer)

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [Group -> TSGroup
forall a b. a -> b -> a
const $$String
[(PropertyName, Property)]
Property
String -> GroupName
String -> PropertyName
GroupName -> [(PropertyName, Property)] -> Group
goldenMempoolPayload :: Property
goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayload1 :: Property
goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload2 :: Property
goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload3 :: Property
goldenMempoolPayload3FilledIn :: Property
discoverGolden, $$discoverRoundTripArg]