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

module Test.Cardano.Chain.Delegation.Certificate (
  tests,
)
where

import Cardano.Chain.Delegation (
  ACertificate (delegateVK),
  Certificate,
  isValid,
  signCertificate,
 )
import Cardano.Ledger.Binary (byronProtVer, decodeFull, serialize, slice)
import Cardano.Prelude
import qualified Data.ByteString.Lazy as BSL
import Hedgehog (Group, Property, assert, discover, forAll, property)
import qualified Hedgehog.Gen as Gen
import Test.Cardano.Chain.Slotting.Gen (genEpochNumber)
import qualified Test.Cardano.Crypto.Dummy as Dummy
import Test.Cardano.Crypto.Gen (genSafeSigner, genVerificationKey)

--------------------------------------------------------------------------------
-- Test Group
--------------------------------------------------------------------------------

tests :: Group
tests :: Group
tests = $$String
[(PropertyName, Property)]
Property
String -> PropertyName
String -> GroupName
GroupName -> [(PropertyName, Property)] -> Group
prop_certificateIncorrect :: Property
prop_certificateCorrect :: Property
discover

--------------------------------------------------------------------------------
-- Certificate Properties
--------------------------------------------------------------------------------

-- | Can validate 'Certificate's produced by 'signCertificate'
prop_certificateCorrect :: Property
prop_certificateCorrect :: Property
prop_certificateCorrect = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Certificate
cert <-
    forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
      forall a b. (a -> b) -> a -> b
$ ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate ProtocolMagicId
Dummy.protocolMagicId
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen VerificationKey
genVerificationKey
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochNumber
genEpochNumber
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SafeSigner
genSafeSigner

  let aCert :: ACertificate ByteString
aCert = Certificate -> ACertificate ByteString
annotateCert Certificate
cert

  forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert forall a b. (a -> b) -> a -> b
$ Annotated ProtocolMagicId ByteString
-> ACertificate ByteString -> Bool
isValid Annotated ProtocolMagicId ByteString
Dummy.annotatedProtocolMagicId ACertificate ByteString
aCert

-- | Cannot validate 'Certificate's with incorrect verification keys
prop_certificateIncorrect :: Property
prop_certificateIncorrect :: Property
prop_certificateIncorrect = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Certificate
cert <-
    forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
      forall a b. (a -> b) -> a -> b
$ ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate ProtocolMagicId
Dummy.protocolMagicId
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen VerificationKey
genVerificationKey
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochNumber
genEpochNumber
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SafeSigner
genSafeSigner
  VerificationKey
badDelegateVK <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGen m, GenBase m ~ Identity) =>
(a -> Bool) -> m a -> m a
Gen.filter (forall a. Eq a => a -> a -> Bool
/= forall a. ACertificate a -> VerificationKey
delegateVK Certificate
cert) Gen VerificationKey
genVerificationKey

  let badCert :: Certificate
badCert = Certificate
cert {delegateVK :: VerificationKey
delegateVK = VerificationKey
badDelegateVK}
      aBadCert :: ACertificate ByteString
aBadCert = Certificate -> ACertificate ByteString
annotateCert Certificate
badCert

  forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Annotated ProtocolMagicId ByteString
-> ACertificate ByteString -> Bool
isValid Annotated ProtocolMagicId ByteString
Dummy.annotatedProtocolMagicId ACertificate ByteString
aBadCert

annotateCert :: Certificate -> ACertificate ByteString
annotateCert :: Certificate -> ACertificate ByteString
annotateCert Certificate
cert =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
BSL.toStrict 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)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall b a. b -> Either a b -> b
fromRight
      (forall a. HasCallStack => Text -> a
panic Text
"prop_certificateCorrect: Round trip broken for Certificate")
    forall a b. (a -> b) -> a -> b
$ forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
byronProtVer ByteString
bytes
  where
    bytes :: ByteString
bytes = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer Certificate
cert