{-# 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.Crypto (Crypto)
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  KeyHash,
  KeyRole (..),
  coerceKeyRole,
  hashKey,
  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.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 (EraCrypto era)) (TwoPhase3ArgInfo era)
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
-> [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
-> [AllIssuerKeys (EraCrypto era) 'StakePool]
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> KeySpace era
KeySpace
    (forall c.
Crypto c =>
Constants
-> [(KeyPair 'Genesis c, AllIssuerKeys c 'GenesisDelegate)]
coreNodeKeys Constants
c)
    (forall c.
Crypto c =>
Constants -> [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates Constants
c)
    (forall c. Crypto c => Constants -> [AllIssuerKeys c 'StakePool]
stakePoolKeys Constants
c)
    (forall c. Crypto c => Constants -> KeyPairs c
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 ::
  Crypto c =>
  Constants ->
  [(KeyPair 'Genesis c, AllIssuerKeys c 'GenesisDelegate)]
coreNodeKeys :: forall c.
Crypto c =>
Constants
-> [(KeyPair 'Genesis c, AllIssuerKeys c 'GenesisDelegate)]
coreNodeKeys c :: Constants
c@Constants {Word64
numCoreNodes :: Constants -> Word64
numCoreNodes :: Word64
numCoreNodes} =
  [ ( (forall {c} {kd :: KeyRole}.
(SignKeyDSIGN (DSIGN c), VKey kd c) -> KeyPair kd c
toKeyPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> (SignKeyDSIGN (DSIGN c), VKey kd c)
mkGenKey) (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
x Word64
0 Word64
0 Word64
0 Word64
0)
    , forall c (r :: KeyRole).
Crypto c =>
Constants -> Word64 -> Word64 -> AllIssuerKeys c 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 c), VKey kd c) -> KeyPair kd c
toKeyPair (SignKeyDSIGN (DSIGN c)
sk, VKey kd c
vk) = forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair VKey kd c
vk SignKeyDSIGN (DSIGN c)
sk

-- Pre-generate a set of keys to use for genesis delegates.
genesisDelegates :: Crypto c => Constants -> [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates :: forall c.
Crypto c =>
Constants -> [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates Constants
c =
  [ forall c (r :: KeyRole).
Crypto c =>
Constants -> Word64 -> Word64 -> AllIssuerKeys c 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 :: Crypto c => Constants -> [AllIssuerKeys c 'StakePool]
stakePoolKeys :: forall c. Crypto c => Constants -> [AllIssuerKeys c 'StakePool]
stakePoolKeys Constants
c =
  [ forall c (r :: KeyRole).
Crypto c =>
Constants -> Word64 -> Word64 -> AllIssuerKeys c 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 ::
  Crypto c =>
  Constants ->
  -- | Namespace parameter. Can be used to differentiate between different
  --   "types" of issuer.
  Word64 ->
  Word64 ->
  AllIssuerKeys c r
issuerKeys :: forall c (r :: KeyRole).
Crypto c =>
Constants -> Word64 -> Word64 -> AllIssuerKeys c r
issuerKeys Constants {Int
maxSlotTrace :: Constants -> Int
maxSlotTrace :: Int
maxSlotTrace} Word64
ns Word64
x =
  let (SignKeyDSIGN (DSIGN c)
skCold, VKey r c
vkCold) = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> (SignKeyDSIGN (DSIGN c), VKey kd c)
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 c
aikCold = forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair VKey r c
vkCold SignKeyDSIGN (DSIGN c)
skCold
        , aikHot :: NonEmpty (KESPeriod, KESKeyPair c)
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 c
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 c
aikColdKeyHash = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey VKey r c
vkCold
        }

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