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

-- | The Leios voting committee: the pools entitled to vote on endorser blocks
-- for one epoch (CIP-0164). The committee type itself is cardano-base's
-- 'LeiosCommittee'; this module re-exports it, gives it an empty value, teaches
-- it to serialize as part of the ledger state, and selects it from the
-- per-epoch stake standing of the pools ('LeiosCandidate').
module Cardano.Ledger.State.LeiosCommittee (
  LeiosCommittee (..),
  LeiosSeat (..),
  emptyLeiosCommittee,
  LeiosCandidate (..),
  selectLeiosCommittee,
  leiosCommitteeToJSON,
) where

import Cardano.Crypto.Leios (LeiosCommittee (..), LeiosSeat (..), Weight, mkLeiosCommittee)
import Cardano.Ledger.BaseTypes (
  EpochInterval,
  StrictMaybe (..),
  addEpochInterval,
  strictMaybeToMaybe,
 )
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Keys (KeyHash, StakePool)
import Cardano.Ledger.Slot (EpochNo)
import Cardano.Ledger.State.StakePool (BlsKey (..), BlsKeyState (..))
import Data.Aeson (ToJSON (..), Value, object, toJSON, (.=))
import Data.Function ((&))
import Data.Ord (Down (..))
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Intro as Intro
import qualified Data.Vector.Strict as VS
import Data.Word (Word16)

-- | The committee with no seats: the value for eras before Leios and for a
-- committee size of zero.
emptyLeiosCommittee :: LeiosCommittee
emptyLeiosCommittee :: LeiosCommittee
emptyLeiosCommittee = Vector LeiosSeat -> LeiosCommittee
UnsafeLeiosCommittee Vector LeiosSeat
forall a. Vector a
VS.empty

-- | A stake pool standing for committee selection. Keeps 'selectLeiosCommittee'
-- independent of the snapshot the candidates are projected from.
data LeiosCandidate = LeiosCandidate
  { LeiosCandidate -> KeyHash StakePool
lcPoolId :: !(KeyHash StakePool)
  -- ^ Tie-breaker: pools of equal stake are seated by ascending id.
  , LeiosCandidate -> CompactForm Coin
lcStake :: !(CompactForm Coin)
  -- ^ Ranking key: pools are seated in descending stake.
  , LeiosCandidate -> Weight
lcWeight :: !Weight
  -- ^ The seat's voting weight: the pool's share of the active stake.
  , LeiosCandidate -> StrictMaybe BlsKeyState
lcKey :: !(StrictMaybe BlsKeyState)
  -- ^ The registered voting key with its registration epoch, if the pool has one.
  }
  deriving (Int -> LeiosCandidate -> ShowS
[LeiosCandidate] -> ShowS
LeiosCandidate -> String
(Int -> LeiosCandidate -> ShowS)
-> (LeiosCandidate -> String)
-> ([LeiosCandidate] -> ShowS)
-> Show LeiosCandidate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosCandidate -> ShowS
showsPrec :: Int -> LeiosCandidate -> ShowS
$cshow :: LeiosCandidate -> String
show :: LeiosCandidate -> String
$cshowList :: [LeiosCandidate] -> ShowS
showList :: [LeiosCandidate] -> ShowS
Show, LeiosCandidate -> LeiosCandidate -> Bool
(LeiosCandidate -> LeiosCandidate -> Bool)
-> (LeiosCandidate -> LeiosCandidate -> Bool) -> Eq LeiosCandidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeiosCandidate -> LeiosCandidate -> Bool
== :: LeiosCandidate -> LeiosCandidate -> Bool
$c/= :: LeiosCandidate -> LeiosCandidate -> Bool
/= :: LeiosCandidate -> LeiosCandidate -> Bool
Eq)

-- | Seat the @committeeSize@ pools with the most stake, largest first, ties
-- broken by ascending pool id. A pool with no registered key, one whose key has
-- aged out (CIP-0164: honoured for @maxKeyAge@ epochs after its registration,
-- judged against the epoch this committee is selected for), or one whose proof
-- of possession does not verify, is seated keyless. A size of zero yields the
-- empty committee without inspecting the candidates, so pre-Dijkstra snapshots
-- carry it for free even when forced.
selectLeiosCommittee ::
  EpochNo -> EpochInterval -> Word16 -> Vector LeiosCandidate -> LeiosCommittee
selectLeiosCommittee :: EpochNo
-> EpochInterval
-> Word16
-> Vector LeiosCandidate
-> LeiosCommittee
selectLeiosCommittee EpochNo
_ EpochInterval
_ Word16
0 Vector LeiosCandidate
_ = LeiosCommittee
emptyLeiosCommittee
selectLeiosCommittee EpochNo
epochNo EpochInterval
maxKeyAge Word16
committeeSize Vector LeiosCandidate
candidates =
  Vector LeiosCandidate
candidates
    Vector LeiosCandidate
-> (Vector LeiosCandidate -> Vector LeiosCandidate)
-> Vector LeiosCandidate
forall a b. a -> (a -> b) -> b
& Vector LeiosCandidate -> Vector LeiosCandidate
sortByStake
    Vector LeiosCandidate
-> (Vector LeiosCandidate -> Vector LeiosCandidate)
-> Vector LeiosCandidate
forall a b. a -> (a -> b) -> b
& Int -> Vector LeiosCandidate -> Vector LeiosCandidate
forall a. Int -> Vector a -> Vector a
V.take Int
size
    Vector LeiosCandidate
-> (Vector LeiosCandidate
    -> Vector
         (StrictMaybe
            (VerKeyDSIGN BLS12381MinSigDSIGN,
             PossessionProofDSIGN BLS12381MinSigDSIGN),
          Weight))
-> Vector
     (StrictMaybe
        (VerKeyDSIGN BLS12381MinSigDSIGN,
         PossessionProofDSIGN BLS12381MinSigDSIGN),
      Weight)
forall a b. a -> (a -> b) -> b
& (LeiosCandidate
 -> (StrictMaybe
       (VerKeyDSIGN BLS12381MinSigDSIGN,
        PossessionProofDSIGN BLS12381MinSigDSIGN),
     Weight))
-> Vector LeiosCandidate
-> Vector
     (StrictMaybe
        (VerKeyDSIGN BLS12381MinSigDSIGN,
         PossessionProofDSIGN BLS12381MinSigDSIGN),
      Weight)
forall a b. (a -> b) -> Vector a -> Vector b
V.map LeiosCandidate
-> (StrictMaybe
      (VerKeyDSIGN BLS12381MinSigDSIGN,
       PossessionProofDSIGN BLS12381MinSigDSIGN),
    Weight)
toSeat
    Vector
  (StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN),
   Weight)
-> (Vector
      (StrictMaybe
         (VerKeyDSIGN BLS12381MinSigDSIGN,
          PossessionProofDSIGN BLS12381MinSigDSIGN),
       Weight)
    -> Vector
         (StrictMaybe
            (VerKeyDSIGN BLS12381MinSigDSIGN,
             PossessionProofDSIGN BLS12381MinSigDSIGN),
          Weight))
-> Vector
     (StrictMaybe
        (VerKeyDSIGN BLS12381MinSigDSIGN,
         PossessionProofDSIGN BLS12381MinSigDSIGN),
      Weight)
forall a b. a -> (a -> b) -> b
& Vector
  (StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN),
   Weight)
-> Vector
     (StrictMaybe
        (VerKeyDSIGN BLS12381MinSigDSIGN,
         PossessionProofDSIGN BLS12381MinSigDSIGN),
      Weight)
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
V.convert
    Vector
  (StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN),
   Weight)
-> (Vector
      (StrictMaybe
         (VerKeyDSIGN BLS12381MinSigDSIGN,
          PossessionProofDSIGN BLS12381MinSigDSIGN),
       Weight)
    -> LeiosCommittee)
-> LeiosCommittee
forall a b. a -> (a -> b) -> b
& Vector
  (StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN),
   Weight)
-> LeiosCommittee
mkLeiosCommittee
  where
    -- Only the top @size@ need to be in order, so partial-sort them in place
    -- and leave the rest untouched instead of ordering the whole vector.
    sortByStake :: Vector LeiosCandidate -> Vector LeiosCandidate
sortByStake = (forall s. MVector s LeiosCandidate -> ST s ())
-> Vector LeiosCandidate -> Vector LeiosCandidate
forall a.
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
V.modify (\MVector s LeiosCandidate
mv -> Comparison LeiosCandidate
-> MVector (PrimState (ST s)) LeiosCandidate -> Int -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> Int -> m ()
Intro.partialSortBy Comparison LeiosCandidate
higherStake MVector s LeiosCandidate
MVector (PrimState (ST s)) LeiosCandidate
mv Int
size)

    size :: Int
size = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int Word16
committeeSize) (Vector LeiosCandidate -> Int
forall a. Vector a -> Int
V.length Vector LeiosCandidate
candidates)

    higherStake :: Comparison LeiosCandidate
higherStake LeiosCandidate
a LeiosCandidate
b =
      (Down (CompactForm Coin), KeyHash StakePool)
-> (Down (CompactForm Coin), KeyHash StakePool) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (CompactForm Coin -> Down (CompactForm Coin)
forall a. a -> Down a
Down (LeiosCandidate -> CompactForm Coin
lcStake LeiosCandidate
a), LeiosCandidate -> KeyHash StakePool
lcPoolId LeiosCandidate
a) (CompactForm Coin -> Down (CompactForm Coin)
forall a. a -> Down a
Down (LeiosCandidate -> CompactForm Coin
lcStake LeiosCandidate
b), LeiosCandidate -> KeyHash StakePool
lcPoolId LeiosCandidate
b)

    toSeat :: LeiosCandidate
-> (StrictMaybe
      (VerKeyDSIGN BLS12381MinSigDSIGN,
       PossessionProofDSIGN BLS12381MinSigDSIGN),
    Weight)
toSeat LeiosCandidate
c = (LeiosCandidate
-> StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN)
honouredKey LeiosCandidate
c, LeiosCandidate -> Weight
lcWeight LeiosCandidate
c)

    -- The key is offered to the committee only while it is still honoured; an
    -- aged-out key leaves the pool seated but keyless.
    honouredKey :: LeiosCandidate
-> StrictMaybe
     (VerKeyDSIGN BLS12381MinSigDSIGN,
      PossessionProofDSIGN BLS12381MinSigDSIGN)
honouredKey LeiosCandidate
c = do
      bks <- LeiosCandidate -> StrictMaybe BlsKeyState
lcKey LeiosCandidate
c
      if epochNo < addEpochInterval (bksRegisteredIn bks) maxKeyAge
        then let BlsKey vk pop = bksKey bks in SJust (vk, pop)
        else SNothing

-- | Render a 'LeiosCommittee' as JSON for ledger purposes.
leiosCommitteeToJSON :: LeiosCommittee -> Value
leiosCommitteeToJSON :: LeiosCommittee -> Value
leiosCommitteeToJSON =
  [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value)
-> (LeiosCommittee -> [Value]) -> LeiosCommittee -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LeiosSeat -> Value) -> [LeiosSeat] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> Value
leiosSeatToJSON ([LeiosSeat] -> [Value])
-> (LeiosCommittee -> [LeiosSeat]) -> LeiosCommittee -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector LeiosSeat -> [LeiosSeat]
forall a. Vector a -> [a]
VS.toList (Vector LeiosSeat -> [LeiosSeat])
-> (LeiosCommittee -> Vector LeiosSeat)
-> LeiosCommittee
-> [LeiosSeat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosCommittee -> Vector LeiosSeat
leiosCommitteeSeats
  where
    leiosSeatToJSON :: LeiosSeat -> Value
leiosSeatToJSON (LeiosSeat Weight
weight StrictMaybe (VerKeyDSIGN BLS12381MinSigDSIGN)
vkey) =
      [Pair] -> Value
object
        [ Key
"seatWeight" Key -> Weight -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Weight
weight
        , Key
"seatVKey" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe (VerKeyDSIGN BLS12381MinSigDSIGN) -> String
forall a. Show a => a -> String
show (StrictMaybe (VerKeyDSIGN BLS12381MinSigDSIGN)
-> Maybe (VerKeyDSIGN BLS12381MinSigDSIGN)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe (VerKeyDSIGN BLS12381MinSigDSIGN)
vkey)
        ]