{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.Federation
-- Description : Core Nodes for Shelley ledger examples
--
-- The genesis/core nodes for Shelley Ledger Examples.
module Test.Cardano.Ledger.Shelley.Examples.Federation (
  numCoreNodes,
  coreNodeSK,
  coreNodeVK,
  coreNodeIssuerKeys,
  coreNodeKeysBySchedule,
  genDelegs,
) where

import Cardano.Crypto.DSIGN (SignKeyDSIGN)
import Cardano.Ledger.BaseTypes (Globals (..))
import Cardano.Ledger.Core (EraPParams (..), PParams (..))
import Cardano.Ledger.Keys (
  DSIGN,
  GenDelegPair (..),
  KeyHash (..),
  KeyRole (..),
  VKey (..),
  coerceKeyRole,
  hashKey,
 )
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Protocol.Crypto (hashVerKeyVRF)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import Cardano.Protocol.TPraos.Rules.Overlay (
  OBftSlot (..),
  lookupInOverlaySchedule,
 )
import qualified Data.List
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
import Lens.Micro ((^.))
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  VRFKeyPair (..),
 )
import Test.Cardano.Ledger.Shelley.Utils

-- | Number of Core Node
numCoreNodes :: Word64
numCoreNodes :: Word64
numCoreNodes = Word64
7

mkAllCoreNodeKeys ::
  Word64 ->
  AllIssuerKeys MockCrypto r
mkAllCoreNodeKeys :: forall (r :: KeyRole). Word64 -> AllIssuerKeys MockCrypto r
mkAllCoreNodeKeys Word64
w =
  KeyPair r
-> VRFKeyPair MockCrypto
-> NonEmpty (KESPeriod, KESKeyPair MockCrypto)
-> KeyHash r
-> AllIssuerKeys MockCrypto r
forall c (r :: KeyRole).
KeyPair r
-> VRFKeyPair c
-> NonEmpty (KESPeriod, KESKeyPair c)
-> KeyHash r
-> AllIssuerKeys c r
AllIssuerKeys
    (VKey r -> SignKeyDSIGN DSIGN -> KeyPair r
forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vkCold SignKeyDSIGN DSIGN
skCold)
    (RawSeed -> VRFKeyPair MockCrypto
forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
w Word64
0 Word64
0 Word64
0 Word64
2))
    ((Word -> KESPeriod
KESPeriod Word
0, RawSeed -> KESKeyPair MockCrypto
forall c. Crypto c => RawSeed -> KESKeyPair c
mkKESKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
w Word64
0 Word64
0 Word64
0 Word64
3)) (KESPeriod, KESKeyPair MockCrypto)
-> [(KESPeriod, KESKeyPair MockCrypto)]
-> NonEmpty (KESPeriod, KESKeyPair MockCrypto)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
    (VKey r -> KeyHash r
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey r
vkCold)
  where
    (SignKeyDSIGN DSIGN
skCold, VKey r
vkCold) = RawSeed -> (SignKeyDSIGN DSIGN, VKey r)
forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
w Word64
0 Word64
0 Word64
0 Word64
1)

coreNodes ::
  [ ( (SignKeyDSIGN DSIGN, VKey GenesisRole)
    , AllIssuerKeys MockCrypto GenesisDelegate
    )
  ]
coreNodes :: [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes =
  [ (RawSeed -> (SignKeyDSIGN DSIGN, VKey GenesisRole)
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), Word64 -> AllIssuerKeys MockCrypto GenesisDelegate
forall (r :: KeyRole). Word64 -> AllIssuerKeys MockCrypto r
mkAllCoreNodeKeys Word64
x)
  | Word64
x <- [Word64
101 .. Word64
100 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
numCoreNodes]
  ]

-- === Signing (Secret) Keys
-- Retrieve the signing key for a core node by providing
-- a number in the range @[0, ... ('numCoreNodes'-1)]@.
coreNodeSK :: Int -> SignKeyDSIGN DSIGN
coreNodeSK :: Int -> SignKeyDSIGN DSIGN
coreNodeSK = (SignKeyDSIGN DSIGN, VKey GenesisRole) -> SignKeyDSIGN DSIGN
forall a b. (a, b) -> a
fst ((SignKeyDSIGN DSIGN, VKey GenesisRole) -> SignKeyDSIGN DSIGN)
-> (Int -> (SignKeyDSIGN DSIGN, VKey GenesisRole))
-> Int
-> SignKeyDSIGN DSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SignKeyDSIGN DSIGN, VKey GenesisRole),
 AllIssuerKeys MockCrypto GenesisDelegate)
-> (SignKeyDSIGN DSIGN, VKey GenesisRole)
forall a b. (a, b) -> a
fst (((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)
 -> (SignKeyDSIGN DSIGN, VKey GenesisRole))
-> (Int
    -> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
        AllIssuerKeys MockCrypto GenesisDelegate))
-> Int
-> (SignKeyDSIGN DSIGN, VKey GenesisRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
-> Int
-> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
    AllIssuerKeys MockCrypto GenesisDelegate)
forall a. HasCallStack => [a] -> Int -> a
!!)

-- | === Verification (Public) Keys
-- Retrieve the verification key for a core node by providing
-- a number in the range @[0, ... ('numCoreNodes'-1)]@.
coreNodeVK :: Int -> VKey GenesisRole
coreNodeVK :: Int -> VKey GenesisRole
coreNodeVK = (SignKeyDSIGN DSIGN, VKey GenesisRole) -> VKey GenesisRole
forall a b. (a, b) -> b
snd ((SignKeyDSIGN DSIGN, VKey GenesisRole) -> VKey GenesisRole)
-> (Int -> (SignKeyDSIGN DSIGN, VKey GenesisRole))
-> Int
-> VKey GenesisRole
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SignKeyDSIGN DSIGN, VKey GenesisRole),
 AllIssuerKeys MockCrypto GenesisDelegate)
-> (SignKeyDSIGN DSIGN, VKey GenesisRole)
forall a b. (a, b) -> a
fst (((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)
 -> (SignKeyDSIGN DSIGN, VKey GenesisRole))
-> (Int
    -> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
        AllIssuerKeys MockCrypto GenesisDelegate))
-> Int
-> (SignKeyDSIGN DSIGN, VKey GenesisRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
-> Int
-> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
    AllIssuerKeys MockCrypto GenesisDelegate)
forall a. HasCallStack => [a] -> Int -> a
!!)

-- | === Block Issuer Keys
-- Retrieve the block issuer keys (cold, VRF, and hot KES keys)
-- for a core node by providing
-- a number in the range @[0, ... ('numCoreNodes'-1)]@.
coreNodeIssuerKeys ::
  Int ->
  AllIssuerKeys MockCrypto GenesisDelegate
coreNodeIssuerKeys :: Int -> AllIssuerKeys MockCrypto GenesisDelegate
coreNodeIssuerKeys = ((SignKeyDSIGN DSIGN, VKey GenesisRole),
 AllIssuerKeys MockCrypto GenesisDelegate)
-> AllIssuerKeys MockCrypto GenesisDelegate
forall a b. (a, b) -> b
snd (((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)
 -> AllIssuerKeys MockCrypto GenesisDelegate)
-> (Int
    -> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
        AllIssuerKeys MockCrypto GenesisDelegate))
-> Int
-> AllIssuerKeys MockCrypto GenesisDelegate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
-> Int
-> ((SignKeyDSIGN DSIGN, VKey GenesisRole),
    AllIssuerKeys MockCrypto GenesisDelegate)
forall a. HasCallStack => [a] -> Int -> a
!!)

-- | === Keys by Overlay Schedule
-- Retrieve all the keys associated with a core node
-- for a given slot and protocol parameters.
-- It will return an error if there is not a core node scheduled
-- for the given slot.
coreNodeKeysBySchedule ::
  forall era.
  (HasCallStack, EraPParams era) =>
  PParams era ->
  Word64 ->
  AllIssuerKeys MockCrypto GenesisDelegate
coreNodeKeysBySchedule :: forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto GenesisDelegate
coreNodeKeysBySchedule PParams era
pp Word64
slot =
  case SlotNo
-> Set (KeyHash GenesisRole)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule
    SlotNo
firstSlot
    (Map (KeyHash GenesisRole) GenDelegPair -> Set (KeyHash GenesisRole)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash GenesisRole) GenDelegPair
genDelegs)
    (PParams era
pp PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG)
    (Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals)
    SlotNo
slot' of
    Maybe OBftSlot
Nothing -> [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a. HasCallStack => [Char] -> a
error ([Char] -> AllIssuerKeys MockCrypto GenesisDelegate)
-> [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a b. (a -> b) -> a -> b
$ [Char]
"coreNodesForSlot: Cannot find keys for slot " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
slot
    Just OBftSlot
NonActiveSlot -> [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a. HasCallStack => [Char] -> a
error ([Char] -> AllIssuerKeys MockCrypto GenesisDelegate)
-> [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a b. (a -> b) -> a -> b
$ [Char]
"coreNodesForSlot: Non-active slot " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
slot
    Just (ActiveSlot KeyHash GenesisRole
gkh) ->
      case (((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)
 -> Bool)
-> [((SignKeyDSIGN DSIGN, VKey GenesisRole),
     AllIssuerKeys MockCrypto GenesisDelegate)]
-> Maybe
     ((SignKeyDSIGN DSIGN, VKey GenesisRole),
      AllIssuerKeys MockCrypto GenesisDelegate)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (\((SignKeyDSIGN DSIGN
_, VKey GenesisRole
gk), AllIssuerKeys MockCrypto GenesisDelegate
_) -> VKey GenesisRole -> KeyHash GenesisRole
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey GenesisRole
gk KeyHash GenesisRole -> KeyHash GenesisRole -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash GenesisRole
gkh) [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes of
        Maybe
  ((SignKeyDSIGN DSIGN, VKey GenesisRole),
   AllIssuerKeys MockCrypto GenesisDelegate)
Nothing ->
          [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a. HasCallStack => [Char] -> a
error ([Char] -> AllIssuerKeys MockCrypto GenesisDelegate)
-> [Char] -> AllIssuerKeys MockCrypto GenesisDelegate
forall a b. (a -> b) -> a -> b
$
            [Char]
"coreNodesForSlot: Cannot find key hash in coreNodes: "
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> KeyHash GenesisRole -> [Char]
forall a. Show a => a -> [Char]
show KeyHash GenesisRole
gkh
        Just ((SignKeyDSIGN DSIGN
_, VKey GenesisRole
_), AllIssuerKeys MockCrypto GenesisDelegate
ak) -> AllIssuerKeys MockCrypto GenesisDelegate
ak
  where
    slot' :: SlotNo
slot' = Word64 -> SlotNo
SlotNo Word64
slot
    firstSlot :: SlotNo
firstSlot = EpochNo -> SlotNo
slotFromEpoch (EpochNo -> SlotNo) -> (SlotNo -> EpochNo) -> SlotNo -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> EpochNo
epochFromSlotNo (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo
slot'

-- | === Genesis Delegation Mapping
-- The map from genesis/core node (verification) key hashes
-- to their delegate's (verification) key hash.
genDelegs :: Map (KeyHash GenesisRole) GenDelegPair
genDelegs :: Map (KeyHash GenesisRole) GenDelegPair
genDelegs =
  [(KeyHash GenesisRole, GenDelegPair)]
-> Map (KeyHash GenesisRole) GenDelegPair
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ ( VKey GenesisRole -> KeyHash GenesisRole
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey GenesisRole -> KeyHash GenesisRole)
-> VKey GenesisRole -> KeyHash GenesisRole
forall a b. (a -> b) -> a -> b
$ (SignKeyDSIGN DSIGN, VKey GenesisRole) -> VKey GenesisRole
forall a b. (a, b) -> b
snd (SignKeyDSIGN DSIGN, VKey GenesisRole)
gkey
      , ( KeyHash GenesisDelegate
-> VRFVerKeyHash GenDelegVRF -> GenDelegPair
GenDelegPair
            (KeyHash GenesisDelegate -> KeyHash GenesisDelegate
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (KeyHash GenesisDelegate -> KeyHash GenesisDelegate)
-> (KeyPair GenesisDelegate -> KeyHash GenesisDelegate)
-> KeyPair GenesisDelegate
-> KeyHash GenesisDelegate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey GenesisDelegate -> KeyHash GenesisDelegate
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey GenesisDelegate -> KeyHash GenesisDelegate)
-> (KeyPair GenesisDelegate -> VKey GenesisDelegate)
-> KeyPair GenesisDelegate
-> KeyHash GenesisDelegate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair GenesisDelegate -> VKey GenesisDelegate
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair GenesisDelegate -> KeyHash GenesisDelegate)
-> KeyPair GenesisDelegate -> KeyHash GenesisDelegate
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys MockCrypto GenesisDelegate -> KeyPair GenesisDelegate
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 (VerKeyVRF FakeVRF -> VRFVerKeyHash GenDelegVRF)
-> (VRFKeyPair MockCrypto -> VerKeyVRF FakeVRF)
-> VRFKeyPair MockCrypto
-> VRFVerKeyHash GenDelegVRF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VRFKeyPair MockCrypto -> VerKeyVRF (VRF MockCrypto)
VRFKeyPair MockCrypto -> VerKeyVRF FakeVRF
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (VRFKeyPair MockCrypto -> VRFVerKeyHash GenDelegVRF)
-> VRFKeyPair MockCrypto -> VRFVerKeyHash GenDelegVRF
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys MockCrypto GenesisDelegate -> VRFKeyPair MockCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys MockCrypto GenesisDelegate
pkeys)
        )
      )
    | ((SignKeyDSIGN DSIGN, VKey GenesisRole)
gkey, AllIssuerKeys MockCrypto GenesisDelegate
pkeys) <- [((SignKeyDSIGN DSIGN, VKey GenesisRole),
  AllIssuerKeys MockCrypto GenesisDelegate)]
coreNodes
    ]