{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Ouroboros.Consensus.Peras.Voting.V1
  ( PerasVotingCommitteeScheme
  , mkPerasVotingCommitteeInput

    -- * For testing purposes
  , extractPerasStakeDistrAndPublicKeys
  ) where

import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Data (Proxy (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import GHC.Base (Any)
import Ouroboros.Consensus.Block.SupportsPeras (PerasCrypto, PerasParams (..))
import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..))
import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS
import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..))
import Ouroboros.Consensus.Committee.WFA
  ( mkExtWFAStakeDistr
  , wFATiebreakerWithEpochNonce
  )
import Ouroboros.Consensus.Committee.WFALS (VotingCommitteeInput (..), WFALS)
import Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
import Ouroboros.Consensus.Ledger.SupportsPeras
  ( LedgerStateSupportsPeras (..)
  )
import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto, PerasPublicKey (..))
import qualified Ouroboros.Consensus.Peras.Error.V1 as V1
import Ouroboros.Consensus.Protocol.Abstract (ChainDepStateSupportsPeras (..))

type PerasVotingCommitteeScheme = WFALS

-- | Key scope used for deriving the BLS public keys from the ledger.
ledgerKeyScope :: BLS.KeyScope
ledgerKeyScope :: ByteString
ledgerKeyScope = ByteString
"PERAS/LEDGER"

extractPerasStakeDistrAndPublicKeys ::
  PoolDistr ->
  Map PoolId (LedgerStake, PerasPublicKey)
extractPerasStakeDistrAndPublicKeys :: PoolDistr -> Map PoolId (LedgerStake, PerasPublicKey)
extractPerasStakeDistrAndPublicKeys =
  (KeyHash StakePool -> PoolId)
-> Map (KeyHash StakePool) (LedgerStake, PerasPublicKey)
-> Map PoolId (LedgerStake, PerasPublicKey)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic KeyHash StakePool -> PoolId
PoolId
    (Map (KeyHash StakePool) (LedgerStake, PerasPublicKey)
 -> Map PoolId (LedgerStake, PerasPublicKey))
-> (PoolDistr
    -> Map (KeyHash StakePool) (LedgerStake, PerasPublicKey))
-> PoolDistr
-> Map PoolId (LedgerStake, PerasPublicKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndividualPoolStake -> Maybe (LedgerStake, PerasPublicKey))
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash StakePool) (LedgerStake, PerasPublicKey)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe IndividualPoolStake -> Maybe (LedgerStake, PerasPublicKey)
extractEntry
    (Map (KeyHash StakePool) IndividualPoolStake
 -> Map (KeyHash StakePool) (LedgerStake, PerasPublicKey))
-> (PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake)
-> PoolDistr
-> Map (KeyHash StakePool) (LedgerStake, PerasPublicKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr
 where
  extractEntry :: IndividualPoolStake -> Maybe (LedgerStake, PerasPublicKey)
extractEntry IndividualPoolStake
poolStake =
    case IndividualPoolStake -> StrictMaybe BlsKey
individualPoolStakeBls IndividualPoolStake
poolStake of
      StrictMaybe BlsKey
SNothing ->
        Maybe (LedgerStake, PerasPublicKey)
forall a. Maybe a
Nothing
      SJust BlsKey
blsKey ->
        (LedgerStake, PerasPublicKey)
-> Maybe (LedgerStake, PerasPublicKey)
forall a. a -> Maybe a
Just
          ( Rational -> LedgerStake
LedgerStake
              (Rational -> LedgerStake)
-> (IndividualPoolStake -> Rational)
-> IndividualPoolStake
-> LedgerStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndividualPoolStake -> Rational
individualPoolStake
              (IndividualPoolStake -> LedgerStake)
-> IndividualPoolStake -> LedgerStake
forall a b. (a -> b) -> a -> b
$ IndividualPoolStake
poolStake
          , PublicKey Any -> PerasPublicKey
PerasPublicKey
              (PublicKey Any -> PerasPublicKey)
-> (BlsKey -> PublicKey Any) -> BlsKey -> PerasPublicKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r2 :: KeyRole) (r1 :: KeyRole).
PublicKey r1 -> PublicKey r2
BLS.coercePublicKey @Any
              (PublicKey (ZonkAny 0) -> PublicKey Any)
-> (BlsKey -> PublicKey (ZonkAny 0)) -> BlsKey -> PublicKey Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BlsKey -> PublicKey (ZonkAny 0)
forall (r :: KeyRole). ByteString -> BlsKey -> PublicKey r
BLS.publicKeyFromLedgerBlsKey ByteString
ledgerKeyScope
              (BlsKey -> PerasPublicKey) -> BlsKey -> PerasPublicKey
forall a b. (a -> b) -> a -> b
$ BlsKey
blsKey
          )

mkPerasVotingCommitteeInput ::
  forall blk ledgerState chainDepState.
  ( PerasCrypto blk ~ PerasBLSCrypto
  , LedgerStateSupportsPeras ledgerState
  , ChainDepStateSupportsPeras chainDepState
  ) =>
  ledgerState EmptyMK ->
  chainDepState ->
  Either (V1.PerasError blk) (VotingCommitteeInput (PerasCrypto blk) WFALS)
mkPerasVotingCommitteeInput :: forall blk (ledgerState :: (* -> * -> *) -> *) chainDepState.
(PerasCrypto blk ~ PerasBLSCrypto,
 LedgerStateSupportsPeras ledgerState,
 ChainDepStateSupportsPeras chainDepState) =>
ledgerState EmptyMK
-> chainDepState
-> Either
     (PerasError blk) (VotingCommitteeInput (PerasCrypto blk) WFALS)
mkPerasVotingCommitteeInput ledgerState EmptyMK
ledgerState chainDepState
headerState = do
  let epochNonce :: Nonce
epochNonce = chainDepState -> Nonce
forall chainDepState.
ChainDepStateSupportsPeras chainDepState =>
chainDepState -> Nonce
getEpochNonce chainDepState
headerState
      poolDistr :: PoolDistr
poolDistr = ledgerState EmptyMK -> PoolDistr
forall (ledgerState :: (* -> * -> *) -> *).
LedgerStateSupportsPeras ledgerState =>
ledgerState EmptyMK -> PoolDistr
getPoolDistr ledgerState EmptyMK
ledgerState
      stakeDistrWithPublicKeys :: Map PoolId (LedgerStake, PerasPublicKey)
stakeDistrWithPublicKeys = PoolDistr -> Map PoolId (LedgerStake, PerasPublicKey)
extractPerasStakeDistrAndPublicKeys PoolDistr
poolDistr
  extWFAStakeDistr <-
    (WFAError -> PerasError blk)
-> (ExtWFAStakeDistr PerasPublicKey
    -> ExtWFAStakeDistr PerasPublicKey)
-> Either WFAError (ExtWFAStakeDistr PerasPublicKey)
-> Either (PerasError blk) (ExtWFAStakeDistr PerasPublicKey)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap WFAError -> PerasError blk
forall blk. WFAError -> PerasError blk
V1.PerasVotingWFAError ExtWFAStakeDistr PerasPublicKey -> ExtWFAStakeDistr PerasPublicKey
forall a. a -> a
id (Either WFAError (ExtWFAStakeDistr PerasPublicKey)
 -> Either (PerasError blk) (ExtWFAStakeDistr PerasPublicKey))
-> Either WFAError (ExtWFAStakeDistr PerasPublicKey)
-> Either (PerasError blk) (ExtWFAStakeDistr PerasPublicKey)
forall a b. (a -> b) -> a -> b
$
      WFATiebreaker
-> Map PoolId (LedgerStake, PerasPublicKey)
-> Either WFAError (ExtWFAStakeDistr PerasPublicKey)
forall a.
WFATiebreaker
-> Map PoolId (LedgerStake, a)
-> Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr
        (Nonce -> WFATiebreaker
wFATiebreakerWithEpochNonce Nonce
epochNonce)
        Map PoolId (LedgerStake, PerasPublicKey)
stakeDistrWithPublicKeys
  pure $
    WFALSVotingCommitteeInput
      epochNonce
      (perasTargetCommitteeSize (getPerasParams (Proxy @blk) ledgerState))
      extWFAStakeDistr