{-# 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.Ledger.BaseTypes (Globals (..))
import Cardano.Ledger.Core (EraCrypto, EraPParams (..), PParams (..))
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  KeyHash (..),
  KeyRole (..),
  SignKeyDSIGN,
  VKey (..),
  coerceKeyRole,
  hashKey,
  hashVerKeyVRF,
 )
import Cardano.Ledger.Slot (SlotNo (..))
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.Generator.Core (
  AllIssuerKeys (..),
  VRFKeyPair (..),
 )
import Test.Cardano.Ledger.Shelley.Utils

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

mkAllCoreNodeKeys ::
  Crypto c =>
  Word64 ->
  AllIssuerKeys c r
mkAllCoreNodeKeys :: forall c (r :: KeyRole). Crypto c => Word64 -> AllIssuerKeys c r
mkAllCoreNodeKeys Word64
w =
  forall v (r :: KeyRole).
KeyPair r v
-> VRFKeyPair v
-> NonEmpty (KESPeriod, KESKeyPair v)
-> KeyHash r v
-> AllIssuerKeys v r
AllIssuerKeys
    (forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair VKey r c
vkCold SignKeyDSIGN (DSIGN c)
skCold)
    (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, 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)) forall a. a -> [a] -> NonEmpty a
NE.:| [])
    (forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey VKey r c
vkCold)
  where
    (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
w Word64
0 Word64
0 Word64
0 Word64
1)

coreNodes ::
  forall c.
  Crypto c =>
  [ ( (SignKeyDSIGN c, VKey 'Genesis c)
    , AllIssuerKeys c 'GenesisDelegate
    )
  ]
coreNodes :: forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes =
  [ (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 => Word64 -> AllIssuerKeys c r
mkAllCoreNodeKeys Word64
x)
  | Word64
x <- [Word64
101 .. Word64
100 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 :: forall c. Crypto c => Int -> SignKeyDSIGN c
coreNodeSK :: forall c. Crypto c => Int -> SignKeyDSIGN c
coreNodeSK = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes @c forall a. [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 :: forall c. Crypto c => Int -> VKey 'Genesis c
coreNodeVK :: forall c. Crypto c => Int -> VKey 'Genesis c
coreNodeVK = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes @c forall a. [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 ::
  forall c.
  Crypto c =>
  Int ->
  AllIssuerKeys c 'GenesisDelegate
coreNodeIssuerKeys :: forall c. Crypto c => Int -> AllIssuerKeys c 'GenesisDelegate
coreNodeIssuerKeys = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes @c forall a. [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 (EraCrypto era) 'GenesisDelegate
coreNodeKeysBySchedule :: forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate
coreNodeKeysBySchedule PParams era
pp Word64
slot =
  case forall c.
SlotNo
-> Set (KeyHash 'Genesis c)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot c)
lookupInOverlaySchedule
    SlotNo
firstSlot
    (forall k a. Map k a -> Set k
Map.keysSet forall c. Crypto c => Map (KeyHash 'Genesis c) (GenDelegPair c)
genDelegs)
    (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG)
    (Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals)
    SlotNo
slot' of
    Maybe (OBftSlot (EraCrypto era))
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"coreNodesForSlot: Cannot find keys for slot " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word64
slot
    Just OBftSlot (EraCrypto era)
NonActiveSlot -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"coreNodesForSlot: Non-active slot " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word64
slot
    Just (ActiveSlot KeyHash 'Genesis (EraCrypto era)
gkh) ->
      case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (\((SignKeyDSIGN (DSIGN (EraCrypto era))
_, VKey 'Genesis (EraCrypto era)
gk), AllIssuerKeys (EraCrypto era) 'GenesisDelegate
_) -> forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey VKey 'Genesis (EraCrypto era)
gk forall a. Eq a => a -> a -> Bool
== KeyHash 'Genesis (EraCrypto era)
gkh) forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes of
        Maybe
  ((SignKeyDSIGN (DSIGN (EraCrypto era)),
    VKey 'Genesis (EraCrypto era)),
   AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
Nothing ->
          forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
            [Char]
"coreNodesForSlot: Cannot find key hash in coreNodes: "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show KeyHash 'Genesis (EraCrypto era)
gkh
        Just ((SignKeyDSIGN (DSIGN (EraCrypto era))
_, VKey 'Genesis (EraCrypto era)
_), AllIssuerKeys (EraCrypto era) 'GenesisDelegate
ak) -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate
ak
  where
    slot' :: SlotNo
slot' = Word64 -> SlotNo
SlotNo Word64
slot
    firstSlot :: SlotNo
firstSlot = EpochNo -> SlotNo
slotFromEpoch forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> EpochNo
epochFromSlotNo 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 ::
  forall c.
  Crypto c =>
  Map (KeyHash 'Genesis c) (GenDelegPair c)
genDelegs :: forall c. Crypto c => Map (KeyHash 'Genesis c) (GenDelegPair c)
genDelegs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ ( forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (SignKeyDSIGN (DSIGN c), VKey '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 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 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)
        )
      )
    | ((SignKeyDSIGN (DSIGN c), VKey 'Genesis c)
gkey, AllIssuerKeys c 'GenesisDelegate
pkeys) <- forall c.
Crypto c =>
[((SignKeyDSIGN c, VKey 'Genesis c),
  AllIssuerKeys c 'GenesisDelegate)]
coreNodes
    ]