{-# 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
    (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
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
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
      Config
config <- PropertyT IO 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 <- Gen (Maybe DCert) -> PropertyT IO (Maybe DCert)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Maybe DCert) -> PropertyT IO (Maybe DCert))
-> Gen (Maybe DCert) -> PropertyT IO (Maybe DCert)
forall a b. (a -> b) -> a -> b
$ DSEnv -> Set (Epoch, VKeyGenesis) -> Gen (Maybe DCert)
dcertGen DSEnv
env Set (Epoch, VKeyGenesis)
forall a. Set a
Set.empty

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

      -- Validate the certificate
      case Maybe DCert
mCert of
        Maybe DCert
Nothing ->
          PropertyT IO ()
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 Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert
                (Bool -> PropertyT IO ()) -> Bool -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Annotated ProtocolMagicId ByteString
-> ACertificate ByteString -> Bool
Concrete.Certificate.isValid (ProtocolMagicId
-> ByteString -> Annotated ProtocolMagicId ByteString
forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pm (Version -> ProtocolMagicId -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer ProtocolMagicId
pm)) ACertificate ByteString
concreteCert
  where
    env :: DSEnv
env =
      DSEnv
        { _dSEnvAllowedDelegators :: Set VKeyGenesis
_dSEnvAllowedDelegators =
            [VKeyGenesis] -> Set VKeyGenesis
forall a. Ord a => [a] -> Set a
Set.fromList
              ([VKeyGenesis] -> Set VKeyGenesis)
-> ([Natural] -> [VKeyGenesis]) -> [Natural] -> Set VKeyGenesis
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
. (Natural -> VKeyGenesis) -> [Natural] -> [VKeyGenesis]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VKey -> VKeyGenesis
VKeyGenesis (VKey -> VKeyGenesis)
-> (Natural -> VKey) -> Natural -> VKeyGenesis
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
. Owner -> VKey
VKey (Owner -> VKey) -> (Natural -> Owner) -> Natural -> VKey
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
. Natural -> Owner
Owner)
              ([Natural] -> Set VKeyGenesis) -> [Natural] -> Set VKeyGenesis
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 (KeyPair -> (VerificationKey, SigningKey))
-> KeyPair -> (VerificationKey, SigningKey)
forall a b. (a -> b) -> a -> b
$ VKey -> KeyPair
vKeyPair VKey
delegatorVKey
    (VerificationKey
delegateVK, SigningKey
_) = KeyPair -> (VerificationKey, SigningKey)
elaborateKeyPair (KeyPair -> (VerificationKey, SigningKey))
-> (VKey -> KeyPair) -> VKey -> (VerificationKey, SigningKey)
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
. VKey -> KeyPair
vKeyPair (VKey -> (VerificationKey, SigningKey))
-> VKey -> (VerificationKey, SigningKey)
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 = Word64 -> EpochNumber
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 (Certificate -> ACertificate ByteString)
-> (DCert -> Certificate) -> DCert -> ACertificate 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
. ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm
  where
    annotateDCert :: Concrete.Certificate -> Concrete.ACertificate ByteString
    annotateDCert :: Certificate -> ACertificate ByteString
annotateDCert Certificate
cert =
      Certificate
cert
        { Concrete.Certificate.aEpoch = Annotated omega (serialize' byronProtVer omega)
        , Concrete.Certificate.annotation = serialize' byronProtVer cert
        }
      where
        omega :: EpochNumber
omega = Certificate -> EpochNumber
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 =
        [KeyHash] -> Set KeyHash
forall a. Ord a => [a] -> Set a
Set.fromList
          ([KeyHash] -> Set KeyHash) -> [KeyHash] -> Set KeyHash
forall a b. (a -> b) -> a -> b
$ VerificationKey -> KeyHash
hashKey
          (VerificationKey -> KeyHash)
-> (VKeyGenesis -> VerificationKey) -> VKeyGenesis -> KeyHash
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
. VKeyGenesis -> VerificationKey
elaborateVKeyGenesis
          (VKeyGenesis -> KeyHash) -> [VKeyGenesis] -> [KeyHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set VKeyGenesis -> [VKeyGenesis]
forall a. Set a -> [a]
Set.toList Set VKeyGenesis
genesisKeys
    , currentEpoch :: EpochNumber
Scheduling.currentEpoch = Word64 -> EpochNumber
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