{-# 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 =
  forall c (r :: KeyRole).
KeyPair r
-> VRFKeyPair c
-> NonEmpty (KESPeriod, KESKeyPair c)
-> KeyHash r
-> AllIssuerKeys c r
AllIssuerKeys
    (forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vkCold SignKeyDSIGN DSIGN
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 (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey r
vkCold)
  where
    (SignKeyDSIGN DSIGN
skCold, VKey r
vkCold) = 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 'Genesis)
    , AllIssuerKeys MockCrypto 'GenesisDelegate
    )
  ]
coreNodes :: [((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes =
  [ (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). Word64 -> AllIssuerKeys MockCrypto 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 :: Int -> SignKeyDSIGN DSIGN
coreNodeSK :: Int -> SignKeyDSIGN DSIGN
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
. ([((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes 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 :: Int -> VKey 'Genesis
coreNodeVK :: Int -> VKey 'Genesis
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
. ([((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes 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 ::
  Int ->
  AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys :: Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes 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 MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule :: forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule PParams era
pp Word64
slot =
  case SlotNo
-> Set (KeyHash 'Genesis)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule
    SlotNo
firstSlot
    (forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) GenDelegPair
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
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
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
gkh) ->
      case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (\((SignKeyDSIGN DSIGN
_, VKey 'Genesis
gk), AllIssuerKeys MockCrypto 'GenesisDelegate
_) -> forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey 'Genesis
gk forall a. Eq a => a -> a -> Bool
== KeyHash 'Genesis
gkh) [((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes of
        Maybe
  ((SignKeyDSIGN DSIGN, VKey 'Genesis),
   AllIssuerKeys MockCrypto '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
gkh
        Just ((SignKeyDSIGN DSIGN
_, VKey 'Genesis
_), AllIssuerKeys MockCrypto 'GenesisDelegate
ak) -> AllIssuerKeys MockCrypto '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 :: Map (KeyHash 'Genesis) GenDelegPair
genDelegs :: Map (KeyHash 'Genesis) GenDelegPair
genDelegs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ ( forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (SignKeyDSIGN DSIGN, VKey 'Genesis)
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). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey 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)
        )
      )
    | ((SignKeyDSIGN DSIGN, VKey 'Genesis)
gkey, AllIssuerKeys MockCrypto 'GenesisDelegate
pkeys) <- [((SignKeyDSIGN DSIGN, VKey 'Genesis),
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes
    ]