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

module Test.Cardano.Chain.Elaboration.Delegation (
  elaborateDCert,
  elaborateDCertAnnotated,
  elaborateDSEnv,
  tests,
)
where

import Byron.Spec.Ledger.Core (
  BlockCount (..),
  Epoch (..),
  Owner (..),
  Slot (..),
  VKey (..),
  VKeyGenesis (..),
 )
import Byron.Spec.Ledger.Delegation (DCert (..), DSEnv (..), dcertGen, delegate, delegator)
import Cardano.Chain.Common (hashKey)
import qualified Cardano.Chain.Common as Concrete
import qualified Cardano.Chain.Delegation as Concrete
import qualified Cardano.Chain.Delegation as Concrete.Certificate
import qualified Cardano.Chain.Delegation.Validation.Scheduling as Scheduling
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.Slotting as Concrete
import Cardano.Crypto (ProtocolMagicId)
import Cardano.Crypto.Signing (noPassSafeSigner)
import Cardano.Ledger.Binary (Annotated (..), byronProtVer, serialize')
import Cardano.Prelude
import qualified Data.Set as Set
import Hedgehog (assert, cover, forAll, property, success)
import Test.Cardano.Chain.Config (readMainetCfg)
import Test.Cardano.Chain.Elaboration.Keys (
  elaborateKeyPair,
  elaborateVKeyGenesis,
  vKeyPair,
 )
import qualified Test.Cardano.Crypto.Dummy as Dummy
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, withTestsTS)

tests :: TSGroup
tests :: TSGroup
tests = $$discoverPropArg

ts_prop_elaboratedCertsValid :: TSProperty
ts_prop_elaboratedCertsValid :: TSProperty
ts_prop_elaboratedCertsValid =
  TestLimit -> Property -> TSProperty
withTestsTS TestLimit
50
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property
    forall a b. (a -> b) -> a -> b
$ do
      Config
config <- forall (m :: * -> *). MonadIO m => m Config
readMainetCfg

      let pm :: ProtocolMagicId
pm = Config -> ProtocolMagicId
Genesis.configProtocolMagicId Config
config

      -- Generate and elaborate a certificate
      Maybe DCert
mCert <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ DSEnv -> Set (Epoch, VKeyGenesis) -> Gen (Maybe DCert)
dcertGen DSEnv
env forall a. Set a
Set.empty

      forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
cover
        CoverPercentage
95
        LabelName
"A certificate was generated"
        (forall a. Maybe a -> Bool
isJust Maybe DCert
mCert)

      -- Validate the certificate
      case Maybe DCert
mCert of
        Maybe DCert
Nothing ->
          forall (m :: * -> *). MonadTest m => m ()
success -- We ignore 'Nothing' values when we the signal generator
          -- fails. Coverage testing ensures we will not generate a
          -- large portion of 'Nothing'.
        Just DCert
cert ->
          let concreteCert :: ACertificate ByteString
concreteCert = ProtocolMagicId -> DCert -> ACertificate ByteString
elaborateDCertAnnotated ProtocolMagicId
pm DCert
cert
           in forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert
                forall a b. (a -> b) -> a -> b
$ Annotated ProtocolMagicId ByteString
-> ACertificate ByteString -> Bool
Concrete.Certificate.isValid (forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pm (forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer ProtocolMagicId
pm)) ACertificate ByteString
concreteCert
  where
    env :: DSEnv
env =
      DSEnv
        { _dSEnvAllowedDelegators :: Set VKeyGenesis
_dSEnvAllowedDelegators =
            forall a. Ord a => [a] -> Set a
Set.fromList
              forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VKey -> VKeyGenesis
VKeyGenesis forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Owner -> VKey
VKey forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Natural -> Owner
Owner)
              forall a b. (a -> b) -> a -> b
$ [Natural
0 .. Natural
6]
        , _dSEnvEpoch :: Epoch
_dSEnvEpoch = Word64 -> Epoch
Epoch Word64
0
        , _dSEnvSlot :: Slot
_dSEnvSlot = Word64 -> Slot
Slot Word64
0
        , _dSEnvK :: BlockCount
_dSEnvK = Word64 -> BlockCount
BlockCount Word64
2160
        }

elaborateDCert :: ProtocolMagicId -> DCert -> Concrete.Certificate
elaborateDCert :: ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm DCert
cert =
  ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Concrete.signCertificate
    ProtocolMagicId
pm
    VerificationKey
delegateVK
    EpochNumber
epochNo
    (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
delegatorSK)
  where
    VKeyGenesis VKey
delegatorVKey = DCert -> VKeyGenesis
delegator DCert
cert
    (VerificationKey
_, SigningKey
delegatorSK) = KeyPair -> (VerificationKey, SigningKey)
elaborateKeyPair forall a b. (a -> b) -> a -> b
$ VKey -> KeyPair
vKeyPair VKey
delegatorVKey
    (VerificationKey
delegateVK, SigningKey
_) = KeyPair -> (VerificationKey, SigningKey)
elaborateKeyPair forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VKey -> KeyPair
vKeyPair forall a b. (a -> b) -> a -> b
$ DCert -> VKey
delegate DCert
cert

    Epoch Word64
e = DCert -> Epoch
depoch DCert
cert

    epochNo :: Concrete.EpochNumber
    epochNo :: EpochNumber
epochNo = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
e

elaborateDCertAnnotated ::
  ProtocolMagicId -> DCert -> Concrete.ACertificate ByteString
elaborateDCertAnnotated :: ProtocolMagicId -> DCert -> ACertificate ByteString
elaborateDCertAnnotated ProtocolMagicId
pm = Certificate -> ACertificate ByteString
annotateDCert forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm
  where
    annotateDCert :: Concrete.Certificate -> Concrete.ACertificate ByteString
    annotateDCert :: Certificate -> ACertificate ByteString
annotateDCert Certificate
cert =
      Certificate
cert
        { aEpoch :: Annotated EpochNumber ByteString
Concrete.Certificate.aEpoch = forall b a. b -> a -> Annotated b a
Annotated EpochNumber
omega (forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer EpochNumber
omega)
        , annotation :: ByteString
Concrete.Certificate.annotation = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer Certificate
cert
        }
      where
        omega :: EpochNumber
omega = forall a. ACertificate a -> EpochNumber
Concrete.Certificate.epoch Certificate
cert

elaborateDSEnv :: DSEnv -> Scheduling.Environment
elaborateDSEnv :: DSEnv -> Environment
elaborateDSEnv DSEnv
abstractEnv =
  Scheduling.Environment
    { protocolMagic :: Annotated ProtocolMagicId ByteString
Scheduling.protocolMagic = Annotated ProtocolMagicId ByteString
Dummy.annotatedProtocolMagicId
    , allowedDelegators :: Set KeyHash
Scheduling.allowedDelegators =
        forall a. Ord a => [a] -> Set a
Set.fromList
          forall a b. (a -> b) -> a -> b
$ VerificationKey -> KeyHash
hashKey
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VKeyGenesis -> VerificationKey
elaborateVKeyGenesis
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set VKeyGenesis
genesisKeys
    , currentEpoch :: EpochNumber
Scheduling.currentEpoch = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
e
    , currentSlot :: SlotNumber
Scheduling.currentSlot = Word64 -> SlotNumber
Concrete.SlotNumber Word64
s
    , k :: BlockCount
Scheduling.k = Word64 -> BlockCount
Concrete.BlockCount Word64
k
    }
  where
    DSEnv Set VKeyGenesis
genesisKeys (Epoch Word64
e) (Slot Word64
s) (BlockCount Word64
k) = DSEnv
abstractEnv