{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

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

import Cardano.Chain.Common (rationalToLovelacePortion)
import Cardano.Chain.Update (ApplicationName (..), SoftforkRule (..))
import Cardano.Crypto (Hash, abstractHash)
import Cardano.Crypto.Raw (Raw (..))
import Cardano.Prelude
import Hedgehog (Property)
import Test.Cardano.Chain.Update.Example (
  exampleInstallerHash,
  examplePayload,
  exampleProof,
  exampleProposal,
  exampleProposalBody,
  exampleProtocolParameters,
  exampleProtocolParametersUpdate,
  exampleProtocolVersion,
  exampleSoftwareVersion,
  exampleSystemTag,
  exampleUpId,
  exampleVote,
 )
import Test.Cardano.Chain.Update.Gen (
  genApplicationName,
  genInstallerHash,
  genPayload,
  genProof,
  genProposal,
  genProposalBody,
  genProtocolParameters,
  genProtocolParametersUpdate,
  genProtocolVersion,
  genSoftforkRule,
  genSoftwareVersion,
  genSystemTag,
  genUpId,
  genUpsData,
  genVote,
 )
import Test.Cardano.Crypto.Gen (feedPM, genHashRaw)
import Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (
  goldenTestCBOR,
  roundTripsCBORBuildable,
  roundTripsCBORShow,
 )
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, eachOfTS)

--------------------------------------------------------------------------------
-- ApplicationName
--------------------------------------------------------------------------------

goldenApplicationName :: Property
goldenApplicationName :: Property
goldenApplicationName = ApplicationName -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ApplicationName
aN FilePath
"golden/cbor/update/ApplicationName"
  where
    aN :: ApplicationName
aN = Text -> ApplicationName
ApplicationName Text
"Golden"

ts_roundTripApplicationName :: TSProperty
ts_roundTripApplicationName :: TSProperty
ts_roundTripApplicationName =
  TestLimit
-> Gen ApplicationName
-> (ApplicationName -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
50 Gen ApplicationName
genApplicationName ApplicationName -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- ProtocolVersion
--------------------------------------------------------------------------------

goldenProtocolVersion :: Property
goldenProtocolVersion :: Property
goldenProtocolVersion = ProtocolVersion -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ProtocolVersion
exampleProtocolVersion FilePath
"golden/cbor/update/ProtocolVersion"

ts_roundTripProtocolVersion :: TSProperty
ts_roundTripProtocolVersion :: TSProperty
ts_roundTripProtocolVersion =
  TestLimit
-> Gen ProtocolVersion
-> (ProtocolVersion -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
50 Gen ProtocolVersion
genProtocolVersion ProtocolVersion -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- ProtocolParameters
--------------------------------------------------------------------------------

goldenProtocolParameters :: Property
goldenProtocolParameters :: Property
goldenProtocolParameters = ProtocolParameters -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ProtocolParameters
bVerDat FilePath
"golden/cbor/update/ProtocolParameters"
  where
    bVerDat :: ProtocolParameters
bVerDat = ProtocolParameters
exampleProtocolParameters

ts_roundTripProtocolParameters :: TSProperty
ts_roundTripProtocolParameters :: TSProperty
ts_roundTripProtocolParameters =
  TestLimit
-> Gen ProtocolParameters
-> (ProtocolParameters -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
50 Gen ProtocolParameters
genProtocolParameters ProtocolParameters -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- ProtocolParametersUpdate
--------------------------------------------------------------------------------

goldenProtocolParametersUpdate :: Property
goldenProtocolParametersUpdate :: Property
goldenProtocolParametersUpdate = ProtocolParametersUpdate -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ProtocolParametersUpdate
ppu FilePath
"golden/cbor/update/ProtocolParametersUpdate"
  where
    ppu :: ProtocolParametersUpdate
ppu = ProtocolParametersUpdate
exampleProtocolParametersUpdate

ts_roundTripProtocolParametersUpdate :: TSProperty
ts_roundTripProtocolParametersUpdate :: TSProperty
ts_roundTripProtocolParametersUpdate =
  TestLimit
-> Gen ProtocolParametersUpdate
-> (ProtocolParametersUpdate -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
50 Gen ProtocolParametersUpdate
genProtocolParametersUpdate ProtocolParametersUpdate -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- HashRaw
--------------------------------------------------------------------------------

goldenBlockHashRaw :: Property
goldenBlockHashRaw :: Property
goldenBlockHashRaw = Hash Raw -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Hash Raw
hRaw FilePath
"golden/cbor/update/HashRaw"
  where
    hRaw :: Hash Raw
hRaw = (Raw -> Hash Raw
forall algo a.
(HashAlgorithm algo, EncCBOR a) =>
a -> AbstractHash algo a
abstractHash (Raw -> Hash Raw) -> Raw -> Hash Raw
forall a b. (a -> b) -> a -> b
$ ByteString -> Raw
Raw (ByteString
"9") :: Hash Raw)

ts_roundTripHashRaw :: TSProperty
ts_roundTripHashRaw :: TSProperty
ts_roundTripHashRaw = TestLimit
-> Gen (Hash Raw) -> (Hash Raw -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
50 Gen (Hash Raw)
genHashRaw Hash Raw -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- SoftforkRule
--------------------------------------------------------------------------------

goldenSoftforkRule :: Property
goldenSoftforkRule :: Property
goldenSoftforkRule = SoftforkRule -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR SoftforkRule
sfR FilePath
"golden/cbor/update/SoftforkRule"
  where
    sfR :: SoftforkRule
sfR =
      LovelacePortion
-> LovelacePortion -> LovelacePortion -> SoftforkRule
SoftforkRule
        (Rational -> LovelacePortion
rationalToLovelacePortion Rational
99e-15)
        (Rational -> LovelacePortion
rationalToLovelacePortion Rational
99e-15)
        (Rational -> LovelacePortion
rationalToLovelacePortion Rational
99e-15)

ts_roundTripSoftforkRule :: TSProperty
ts_roundTripSoftforkRule :: TSProperty
ts_roundTripSoftforkRule = TestLimit
-> Gen SoftforkRule
-> (SoftforkRule -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
10 Gen SoftforkRule
genSoftforkRule SoftforkRule -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- SoftwareVersion
--------------------------------------------------------------------------------

goldenSoftwareVersion :: Property
goldenSoftwareVersion :: Property
goldenSoftwareVersion = SoftwareVersion -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR SoftwareVersion
exampleSoftwareVersion FilePath
"golden/cbor/update/SoftwareVersion"

ts_roundTripSoftwareVersion :: TSProperty
ts_roundTripSoftwareVersion :: TSProperty
ts_roundTripSoftwareVersion =
  TestLimit
-> Gen SoftwareVersion
-> (SoftwareVersion -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
10 Gen SoftwareVersion
genSoftwareVersion SoftwareVersion -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- SystemTag
--------------------------------------------------------------------------------

goldenSystemTag :: Property
goldenSystemTag :: Property
goldenSystemTag = SystemTag -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR SystemTag
exampleSystemTag FilePath
"golden/cbor/update/SystemTag"

ts_roundTripSystemTag :: TSProperty
ts_roundTripSystemTag :: TSProperty
ts_roundTripSystemTag = TestLimit
-> Gen SystemTag -> (SystemTag -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
10 Gen SystemTag
genSystemTag SystemTag -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- InstallerHash
--------------------------------------------------------------------------------

goldenInstallerHash :: Property
goldenInstallerHash :: Property
goldenInstallerHash = InstallerHash -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR InstallerHash
exampleInstallerHash FilePath
"golden/cbor/update/InstallerHash"

ts_roundTripInstallerHash :: TSProperty
ts_roundTripInstallerHash :: TSProperty
ts_roundTripInstallerHash = TestLimit
-> Gen InstallerHash
-> (InstallerHash -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 Gen InstallerHash
genInstallerHash InstallerHash -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- UpdatePayload
--------------------------------------------------------------------------------

goldenUpdatePayload :: Property
goldenUpdatePayload :: Property
goldenUpdatePayload = Payload -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Payload
examplePayload FilePath
"golden/cbor/update/Payload"

ts_roundTripUpdatePayload :: TSProperty
ts_roundTripUpdatePayload :: TSProperty
ts_roundTripUpdatePayload =
  TestLimit
-> Gen Payload -> (Payload -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Payload) -> Gen Payload
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Payload
genPayload) Payload -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- UpdateProof
--------------------------------------------------------------------------------

goldenUpdateProof :: Property
goldenUpdateProof :: Property
goldenUpdateProof = Proof -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Proof
exampleProof FilePath
"golden/cbor/update/Proof"

ts_roundTripUpdateProof :: TSProperty
ts_roundTripUpdateProof :: TSProperty
ts_roundTripUpdateProof = TestLimit -> Gen Proof -> (Proof -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Proof) -> Gen Proof
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Proof
genProof) Proof -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- UpdateProposal
--------------------------------------------------------------------------------

goldenUpdateProposal :: Property
goldenUpdateProposal :: Property
goldenUpdateProposal = Proposal -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Proposal
exampleProposal FilePath
"golden/cbor/update/Proposal"

ts_roundTripUpdateProposal :: TSProperty
ts_roundTripUpdateProposal :: TSProperty
ts_roundTripUpdateProposal =
  TestLimit
-> Gen Proposal -> (Proposal -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Proposal) -> Gen Proposal
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Proposal
genProposal) Proposal -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- ProposalBody
--------------------------------------------------------------------------------

goldenProposalBody :: Property
goldenProposalBody :: Property
goldenProposalBody = ProposalBody -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ProposalBody
exampleProposalBody FilePath
"golden/cbor/update/ProposalBody"

ts_roundTripProposalBody :: TSProperty
ts_roundTripProposalBody :: TSProperty
ts_roundTripProposalBody = TestLimit
-> Gen ProposalBody
-> (ProposalBody -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 Gen ProposalBody
genProposalBody ProposalBody -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

--------------------------------------------------------------------------------
-- UpdateVote
--------------------------------------------------------------------------------

goldenUpdateVote :: Property
goldenUpdateVote :: Property
goldenUpdateVote = Vote -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Vote
exampleVote FilePath
"golden/cbor/update/Vote"

ts_roundTripUpdateVote :: TSProperty
ts_roundTripUpdateVote :: TSProperty
ts_roundTripUpdateVote = TestLimit -> Gen Vote -> (Vote -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Vote) -> Gen Vote
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Vote
genVote) Vote -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- UpId
--------------------------------------------------------------------------------

goldenUpId :: Property
goldenUpId :: Property
goldenUpId = UpId -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR UpId
exampleUpId FilePath
"golden/cbor/update/UpId"

ts_roundTripUpId :: TSProperty
ts_roundTripUpId :: TSProperty
ts_roundTripUpId = TestLimit -> Gen UpId -> (UpId -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen UpId) -> Gen UpId
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen UpId
genUpId) UpId -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- UpsData NB: UpsData is not a type it is a record accessor of `ProposalBody`
--------------------------------------------------------------------------------

ts_roundTripUpsData :: TSProperty
ts_roundTripUpsData :: TSProperty
ts_roundTripUpsData = TestLimit
-> Gen (Map SystemTag InstallerHash)
-> (Map SystemTag InstallerHash -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 Gen (Map SystemTag InstallerHash)
genUpsData Map SystemTag InstallerHash -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

--------------------------------------------------------------------------------
-- Main test export
--------------------------------------------------------------------------------

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [Group -> TSGroup
forall a b. a -> b -> a
const $$FilePath
[(PropertyName, Property)]
Property
FilePath -> GroupName
FilePath -> PropertyName
GroupName -> [(PropertyName, Property)] -> Group
goldenApplicationName :: Property
goldenProtocolVersion :: Property
goldenProtocolParameters :: Property
goldenProtocolParametersUpdate :: Property
goldenBlockHashRaw :: Property
goldenSoftforkRule :: Property
goldenSoftwareVersion :: Property
goldenSystemTag :: Property
goldenInstallerHash :: Property
goldenUpdatePayload :: Property
goldenUpdateProof :: Property
goldenUpdateProposal :: Property
goldenProposalBody :: Property
goldenUpdateVote :: Property
goldenUpId :: Property
discoverGolden, $$discoverRoundTripArg]