{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Pre-generated items to use in traces.
--
--   Functions in this module make specific assumptions about the sets of keys
--   involved, and thus cannot be used as generic generators.
module Test.Cardano.Ledger.Shelley.Generator.Presets (
  coreNodeKeys,
  keySpace,
  genEnv,
  genesisDelegs0,
  someKeyPairs,
  keyPairs,
  scriptSpace,
)
where

import Cardano.Ledger.Core (EraScript, hashScript)
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  KeyHash,
  KeyRole (..),
  coerceKeyRole,
  hashKey,
 )
import Cardano.Protocol.Crypto (hashVerKeyVRF)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Word (Word64)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), allScripts, someKeyPairs)
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (keyPairs)
import Test.Cardano.Ledger.Shelley.Utils (
  maxKESIterations,
  mkKESKeyPair,
  mkVRFKeyPair,
  slotsPerKESIteration,
 )

-- =================================================================

-- | Example generator environment, consisting of default constants and an
-- corresponding keyspace.
genEnv ::
  forall era.
  EraGen era =>
  Proxy era ->
  Constants ->
  GenEnv era
genEnv :: forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv Proxy era
_ Constants
constants =
  forall era.
KeySpace era -> ScriptSpace era -> Constants -> GenEnv era
GenEnv
    (forall era. EraGen era => Constants -> KeySpace era
keySpace Constants
constants)
    (forall era.
EraScript era =>
[TwoPhase3ArgInfo era] -> [TwoPhase2ArgInfo era] -> ScriptSpace era
scriptSpace @era (forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg @era) (forall era. EraGen era => [TwoPhase2ArgInfo era]
genEraTwoPhase2Arg @era))
    Constants
constants

-- | An Example Script space for use in Trace generators
scriptSpace ::
  forall era.
  EraScript era =>
  [TwoPhase3ArgInfo era] ->
  [TwoPhase2ArgInfo era] ->
  ScriptSpace era
scriptSpace :: forall era.
EraScript era =>
[TwoPhase3ArgInfo era] -> [TwoPhase2ArgInfo era] -> ScriptSpace era
scriptSpace [TwoPhase3ArgInfo era]
scripts3 [TwoPhase2ArgInfo era]
scripts2 =
  forall era.
[TwoPhase3ArgInfo era]
-> [TwoPhase2ArgInfo era]
-> Map ScriptHash (TwoPhase3ArgInfo era)
-> Map ScriptHash (TwoPhase2ArgInfo era)
-> ScriptSpace era
ScriptSpace
    [TwoPhase3ArgInfo era]
scripts3
    [TwoPhase2ArgInfo era]
scripts2
    (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall era. EraScript era => Script era -> ScriptHash
hashScript @era (forall era. TwoPhase3ArgInfo era -> Script era
getScript3 TwoPhase3ArgInfo era
s), TwoPhase3ArgInfo era
s) | TwoPhase3ArgInfo era
s <- [TwoPhase3ArgInfo era]
scripts3])
    (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall era. EraScript era => Script era -> ScriptHash
hashScript @era (forall era. TwoPhase2ArgInfo era -> Script era
getScript2 TwoPhase2ArgInfo era
s), TwoPhase2ArgInfo era
s) | TwoPhase2ArgInfo era
s <- [TwoPhase2ArgInfo era]
scripts2])

-- | Example keyspace for use in generators
keySpace ::
  forall era.
  EraGen era =>
  Constants ->
  KeySpace era
keySpace :: forall era. EraGen era => Constants -> KeySpace era
keySpace Constants
c =
  forall era.
ScriptClass era =>
[(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
-> [AllIssuerKeys MockCrypto 'GenesisDelegate]
-> [AllIssuerKeys MockCrypto 'StakePool]
-> KeyPairs
-> [(Script era, Script era)]
-> KeySpace era
KeySpace
    (Constants
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodeKeys Constants
c)
    (Constants -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
genesisDelegates Constants
c)
    (Constants -> [AllIssuerKeys MockCrypto 'StakePool]
stakePoolKeys Constants
c)
    (Constants -> KeyPairs
keyPairs Constants
c)
    (forall era. EraGen era => Constants -> [(Script era, Script era)]
allScripts @era Constants
c)

-- Pairs of (genesis key, node keys)
--
-- NOTE: we use a seed range in the [1000...] range
-- to create keys that don't overlap with any of the other generated keys
coreNodeKeys ::
  Constants ->
  [(KeyPair 'Genesis, AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodeKeys :: Constants
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodeKeys c :: Constants
c@Constants {Word64
numCoreNodes :: Constants -> Word64
numCoreNodes :: Word64
numCoreNodes} =
  [ ( (forall {kd :: KeyRole}. (SignKeyDSIGN DSIGN, VKey kd) -> KeyPair kd
toKeyPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkGenKey) (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
x Word64
0 Word64
0 Word64
0 Word64
0)
    , forall (r :: KeyRole).
Constants -> Word64 -> Word64 -> AllIssuerKeys MockCrypto r
issuerKeys Constants
c Word64
0 Word64
x
    )
  | Word64
x <- [Word64
1001 .. Word64
1000 forall a. Num a => a -> a -> a
+ Word64
numCoreNodes]
  ]
  where
    toKeyPair :: (SignKeyDSIGN DSIGN, VKey kd) -> KeyPair kd
toKeyPair (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey kd
vk SignKeyDSIGN DSIGN
sk

-- Pre-generate a set of keys to use for genesis delegates.
genesisDelegates :: Constants -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
genesisDelegates :: Constants -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
genesisDelegates Constants
c =
  [ forall (r :: KeyRole).
Constants -> Word64 -> Word64 -> AllIssuerKeys MockCrypto r
issuerKeys Constants
c Word64
20 Word64
x
  | Word64
x <- [Word64
0 .. Word64
50]
  ]

-- Pre-generate a set of keys to use for stake pools.
stakePoolKeys :: Constants -> [AllIssuerKeys MockCrypto 'StakePool]
stakePoolKeys :: Constants -> [AllIssuerKeys MockCrypto 'StakePool]
stakePoolKeys Constants
c =
  [ forall (r :: KeyRole).
Constants -> Word64 -> Word64 -> AllIssuerKeys MockCrypto r
issuerKeys Constants
c Word64
10 Word64
x
  | Word64
x <- [Word64
0 .. Word64
50]
  ]

-- | Generate all keys for any entity which will be issuing blocks.
issuerKeys ::
  Constants ->
  -- | Namespace parameter. Can be used to differentiate between different
  --   "types" of issuer.
  Word64 ->
  Word64 ->
  AllIssuerKeys MockCrypto r
issuerKeys :: forall (r :: KeyRole).
Constants -> Word64 -> Word64 -> AllIssuerKeys MockCrypto r
issuerKeys Constants {Int
maxSlotTrace :: Constants -> Int
maxSlotTrace :: Int
maxSlotTrace} Word64
ns Word64
x =
  let (SignKeyDSIGN DSIGN
skCold, VKey r
vkCold) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
x Word64
0 Word64
0 Word64
0 (Word64
ns forall a. Num a => a -> a -> a
+ Word64
1))
      iters :: NonEmpty Int
iters =
        Int
0
          forall a. a -> [a] -> NonEmpty a
:| [ Int
1
             .. Int
1
              forall a. Num a => a -> a -> a
+ ( Int
maxSlotTrace
                    forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
maxKESIterations forall a. Num a => a -> a -> a
* Word64
slotsPerKESIteration)
                )
             ]
   in AllIssuerKeys
        { aikCold :: KeyPair r
aikCold = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vkCold SignKeyDSIGN DSIGN
skCold
        , aikHot :: NonEmpty (KESPeriod, KESKeyPair MockCrypto)
aikHot =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              ( \Int
iter ->
                  ( Word -> KESPeriod
KESPeriod (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
iter forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESIterations))
                  , forall c. Crypto c => RawSeed -> KESKeyPair c
mkKESKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
x Word64
0 Word64
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iter) (Word64
ns forall a. Num a => a -> a -> a
+ Word64
3))
                  )
              )
              NonEmpty Int
iters
        , aikVrf :: VRFKeyPair MockCrypto
aikVrf = forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
x Word64
0 Word64
0 Word64
0 (Word64
ns forall a. Num a => a -> a -> a
+ Word64
2))
        , aikColdKeyHash :: KeyHash r
aikColdKeyHash = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey r
vkCold
        }

genesisDelegs0 ::
  Constants ->
  Map (KeyHash 'Genesis) GenDelegPair
genesisDelegs0 :: Constants -> Map (KeyHash 'Genesis) GenDelegPair
genesisDelegs0 Constants
c =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ ( forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey GenesisKeyPair MockCrypto
gkey
      , KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF -> GenDelegPair
GenDelegPair
          (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys MockCrypto 'GenesisDelegate
pkeys)
          (forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys MockCrypto 'GenesisDelegate
pkeys)
      )
    | (GenesisKeyPair MockCrypto
gkey, AllIssuerKeys MockCrypto 'GenesisDelegate
pkeys) <- Constants
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodeKeys Constants
c
    ]
  where
    hashVKey :: KeyPair kd -> KeyHash kd
hashVKey = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey