{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Various things common to iterations of the Praos protocol.
module Ouroboros.Consensus.Protocol.Praos.Common
  ( MaxMajorProtVer (..)
  , HasMaxMajorProtVer (..)
  , PraosCanBeLeader (..)
  , PraosTiebreakerView (..)
  , VRFTiebreakerFlavor (..)

    -- * node support
  , PraosCredentialsSource (..)
  , PraosNonces (..)
  , PraosProtocolSupportsNode (..)
  , instantiatePraosCredentials
  ) where

import qualified Cardano.Crypto.KES.Class as KES
import Cardano.Crypto.VRF
import qualified Cardano.Crypto.VRF as VRF
import qualified Cardano.KESAgent.KES.Crypto as Agent
import Cardano.Ledger.BaseTypes (Nonce)
import qualified Cardano.Ledger.BaseTypes as SL
import Cardano.Ledger.Binary (FromCBOR, ToCBOR)
import Cardano.Ledger.Keys (DSIGN, KeyHash, KeyRole (BlockIssuer))
import qualified Cardano.Ledger.Shelley.API as SL
import Cardano.Protocol.Crypto (Crypto, KES, VRF)
import qualified Cardano.Protocol.TPraos.OCert as OCert
import Cardano.Slotting.Slot (SlotNo)
import qualified Control.Tracer as Tracer
import Data.Function (on)
import Data.Map.Strict (Map)
import Data.Ord (Down (Down))
import Data.Void
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos.AgentClient

-- | The maximum major protocol version.
--
-- This refers to the largest __ledger__ version that this node supports.
--
-- Once the ledger protocol version (as reported by the ledger state)
-- exceeds this version we will consider all blocks invalid. This is
-- called the "obsolete node check" (see the 'ObsoleteNode' error
-- constructor).
--
-- Major ledger protocol versions are used to trigger both intra and
-- inter era hard forks, which can potentially change the set of
-- ledger rules that are applied.
--
-- Minor ledger protocol versions were intended to signal soft forks
-- but they're currently unused, and they're irrelevant for the
-- consensus logic.
--
-- For Cardano mainnet, the Shelley era has major protocol version
-- __2__.  For more details, see [this
-- table](https://github.com/cardano-foundation/CIPs/blob/master/CIP-0059/feature-table.md)
newtype MaxMajorProtVer = MaxMajorProtVer
  { MaxMajorProtVer -> Version
getMaxMajorProtVer :: SL.Version
  }
  deriving (MaxMajorProtVer -> MaxMajorProtVer -> Bool
(MaxMajorProtVer -> MaxMajorProtVer -> Bool)
-> (MaxMajorProtVer -> MaxMajorProtVer -> Bool)
-> Eq MaxMajorProtVer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
== :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
$c/= :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
/= :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
Eq, Int -> MaxMajorProtVer -> ShowS
[MaxMajorProtVer] -> ShowS
MaxMajorProtVer -> String
(Int -> MaxMajorProtVer -> ShowS)
-> (MaxMajorProtVer -> String)
-> ([MaxMajorProtVer] -> ShowS)
-> Show MaxMajorProtVer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MaxMajorProtVer -> ShowS
showsPrec :: Int -> MaxMajorProtVer -> ShowS
$cshow :: MaxMajorProtVer -> String
show :: MaxMajorProtVer -> String
$cshowList :: [MaxMajorProtVer] -> ShowS
showList :: [MaxMajorProtVer] -> ShowS
Show, (forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x)
-> (forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer)
-> Generic MaxMajorProtVer
forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer
forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x
from :: forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x
$cto :: forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer
to :: forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer
Generic)
  deriving newtype (Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
Proxy MaxMajorProtVer -> String
(Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo))
-> (Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo))
-> (Proxy MaxMajorProtVer -> String)
-> NoThunks MaxMajorProtVer
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
noThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy MaxMajorProtVer -> String
showTypeOf :: Proxy MaxMajorProtVer -> String
NoThunks, Typeable MaxMajorProtVer
Typeable MaxMajorProtVer =>
(MaxMajorProtVer -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy MaxMajorProtVer -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [MaxMajorProtVer] -> Size)
-> ToCBOR MaxMajorProtVer
MaxMajorProtVer -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MaxMajorProtVer] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy MaxMajorProtVer -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
$ctoCBOR :: MaxMajorProtVer -> Encoding
toCBOR :: MaxMajorProtVer -> Encoding
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy MaxMajorProtVer -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy MaxMajorProtVer -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MaxMajorProtVer] -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MaxMajorProtVer] -> Size
ToCBOR, Typeable MaxMajorProtVer
Typeable MaxMajorProtVer =>
(forall s. Decoder s MaxMajorProtVer)
-> (Proxy MaxMajorProtVer -> Text) -> FromCBOR MaxMajorProtVer
Proxy MaxMajorProtVer -> Text
forall s. Decoder s MaxMajorProtVer
forall a.
Typeable a =>
(forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
$cfromCBOR :: forall s. Decoder s MaxMajorProtVer
fromCBOR :: forall s. Decoder s MaxMajorProtVer
$clabel :: Proxy MaxMajorProtVer -> Text
label :: Proxy MaxMajorProtVer -> Text
FromCBOR)

class HasMaxMajorProtVer proto where
  protoMaxMajorPV :: ConsensusConfig proto -> MaxMajorProtVer

-- | View of the tip of a header fragment for deciding between chains of equal
-- length.
data PraosTiebreakerView c = PraosTiebreakerView
  { forall c. PraosTiebreakerView c -> SlotNo
ptvSlotNo :: SlotNo
  , forall c. PraosTiebreakerView c -> VKey 'BlockIssuer
ptvIssuer :: SL.VKey 'SL.BlockIssuer
  , forall c. PraosTiebreakerView c -> Word64
ptvIssueNo :: Word64
  , forall c. PraosTiebreakerView c -> OutputVRF (VRF c)
ptvTieBreakVRF :: VRF.OutputVRF (VRF c)
  }
  deriving (Int -> PraosTiebreakerView c -> ShowS
[PraosTiebreakerView c] -> ShowS
PraosTiebreakerView c -> String
(Int -> PraosTiebreakerView c -> ShowS)
-> (PraosTiebreakerView c -> String)
-> ([PraosTiebreakerView c] -> ShowS)
-> Show (PraosTiebreakerView c)
forall c. Int -> PraosTiebreakerView c -> ShowS
forall c. [PraosTiebreakerView c] -> ShowS
forall c. PraosTiebreakerView c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Int -> PraosTiebreakerView c -> ShowS
showsPrec :: Int -> PraosTiebreakerView c -> ShowS
$cshow :: forall c. PraosTiebreakerView c -> String
show :: PraosTiebreakerView c -> String
$cshowList :: forall c. [PraosTiebreakerView c] -> ShowS
showList :: [PraosTiebreakerView c] -> ShowS
Show, PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
(PraosTiebreakerView c -> PraosTiebreakerView c -> Bool)
-> (PraosTiebreakerView c -> PraosTiebreakerView c -> Bool)
-> Eq (PraosTiebreakerView c)
forall c. PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
== :: PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
$c/= :: forall c. PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
/= :: PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
Eq, (forall x. PraosTiebreakerView c -> Rep (PraosTiebreakerView c) x)
-> (forall x.
    Rep (PraosTiebreakerView c) x -> PraosTiebreakerView c)
-> Generic (PraosTiebreakerView c)
forall x. Rep (PraosTiebreakerView c) x -> PraosTiebreakerView c
forall x. PraosTiebreakerView c -> Rep (PraosTiebreakerView c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosTiebreakerView c) x -> PraosTiebreakerView c
forall c x. PraosTiebreakerView c -> Rep (PraosTiebreakerView c) x
$cfrom :: forall c x. PraosTiebreakerView c -> Rep (PraosTiebreakerView c) x
from :: forall x. PraosTiebreakerView c -> Rep (PraosTiebreakerView c) x
$cto :: forall c x. Rep (PraosTiebreakerView c) x -> PraosTiebreakerView c
to :: forall x. Rep (PraosTiebreakerView c) x -> PraosTiebreakerView c
Generic, Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
Proxy (PraosTiebreakerView c) -> String
(Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo))
-> (Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo))
-> (Proxy (PraosTiebreakerView c) -> String)
-> NoThunks (PraosTiebreakerView c)
forall c. Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
forall c. Proxy (PraosTiebreakerView c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall c. Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
noThunks :: Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c. Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PraosTiebreakerView c -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c. Proxy (PraosTiebreakerView c) -> String
showTypeOf :: Proxy (PraosTiebreakerView c) -> String
NoThunks)

-- | When to compare the VRF tiebreakers.
data VRFTiebreakerFlavor
  = -- | Always compare the VRF tiebreakers. This is the behavior of all eras
    -- before Conway. Once mainnet has transitioned to Conway, we can remove
    -- this option. (The honest /historical/ Ouroboros chain cannot rely on
    -- tiebreakers to win, so /retroactively/ disabling the tiebreaker won't
    -- matter.)
    UnrestrictedVRFTiebreaker
  | -- | Only compare the VRF tiebreakers when the slot numbers differ by at
    -- most the given number of slots.
    --
    -- The main motivation is as follows:
    --
    -- When two blocks A and B with the same block number differ in their slot
    -- number by more than Δ (the maximum message delay from Praos), say
    -- @slot(A) + Δ < slot(B)@, the issuer of B should have been able to mint a
    -- block with a block number higher than A (eg by minting on top of A) under
    -- normal circumstances. The reason for this not being the case might have
    -- been due to A being sent very late, or due to the issuer of B ignoring A
    -- (intentionally, or due to poor configuration/resource provision). In any
    -- case, we do not want to allow the block that was diffused later to still
    -- win by having a better VRF tiebreaker. This makes it less likely for
    -- properly configured pools to lose blocks because of poorly configured
    -- pools.
    RestrictedVRFTiebreaker SlotNo
  deriving stock (Int -> VRFTiebreakerFlavor -> ShowS
[VRFTiebreakerFlavor] -> ShowS
VRFTiebreakerFlavor -> String
(Int -> VRFTiebreakerFlavor -> ShowS)
-> (VRFTiebreakerFlavor -> String)
-> ([VRFTiebreakerFlavor] -> ShowS)
-> Show VRFTiebreakerFlavor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VRFTiebreakerFlavor -> ShowS
showsPrec :: Int -> VRFTiebreakerFlavor -> ShowS
$cshow :: VRFTiebreakerFlavor -> String
show :: VRFTiebreakerFlavor -> String
$cshowList :: [VRFTiebreakerFlavor] -> ShowS
showList :: [VRFTiebreakerFlavor] -> ShowS
Show, VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool
(VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool)
-> (VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool)
-> Eq VRFTiebreakerFlavor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool
== :: VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool
$c/= :: VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool
/= :: VRFTiebreakerFlavor -> VRFTiebreakerFlavor -> Bool
Eq, (forall x. VRFTiebreakerFlavor -> Rep VRFTiebreakerFlavor x)
-> (forall x. Rep VRFTiebreakerFlavor x -> VRFTiebreakerFlavor)
-> Generic VRFTiebreakerFlavor
forall x. Rep VRFTiebreakerFlavor x -> VRFTiebreakerFlavor
forall x. VRFTiebreakerFlavor -> Rep VRFTiebreakerFlavor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VRFTiebreakerFlavor -> Rep VRFTiebreakerFlavor x
from :: forall x. VRFTiebreakerFlavor -> Rep VRFTiebreakerFlavor x
$cto :: forall x. Rep VRFTiebreakerFlavor x -> VRFTiebreakerFlavor
to :: forall x. Rep VRFTiebreakerFlavor x -> VRFTiebreakerFlavor
Generic)
  deriving anyclass Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo)
Proxy VRFTiebreakerFlavor -> String
(Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo))
-> (Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo))
-> (Proxy VRFTiebreakerFlavor -> String)
-> NoThunks VRFTiebreakerFlavor
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo)
noThunks :: Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> VRFTiebreakerFlavor -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy VRFTiebreakerFlavor -> String
showTypeOf :: Proxy VRFTiebreakerFlavor -> String
NoThunks

-- Used to implement the 'Ord' and 'ChainOrder' instances for Praos.
comparePraos ::
  VRFTiebreakerFlavor ->
  PraosTiebreakerView c ->
  PraosTiebreakerView c ->
  Ordering
comparePraos :: forall c.
VRFTiebreakerFlavor
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
comparePraos VRFTiebreakerFlavor
tiebreakerFlavor =
  (PraosTiebreakerView c -> PraosTiebreakerView c -> Bool)
-> (PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering)
-> PraosTiebreakerView c
-> PraosTiebreakerView c
-> Ordering
forall a.
(a -> a -> Bool) -> (a -> a -> Ordering) -> a -> a -> Ordering
when' PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
forall {c} {c}.
PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
issueNoArmed (Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Word64 -> Ordering)
-> (PraosTiebreakerView c -> Word64)
-> PraosTiebreakerView c
-> PraosTiebreakerView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PraosTiebreakerView c -> Word64
forall c. PraosTiebreakerView c -> Word64
ptvIssueNo)
    (PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering)
-> (PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering)
-> PraosTiebreakerView c
-> PraosTiebreakerView c
-> Ordering
forall a. Semigroup a => a -> a -> a
<> (PraosTiebreakerView c -> PraosTiebreakerView c -> Bool)
-> (PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering)
-> PraosTiebreakerView c
-> PraosTiebreakerView c
-> Ordering
forall a.
(a -> a -> Bool) -> (a -> a -> Ordering) -> a -> a -> Ordering
when' PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
vrfArmed (Down (OutputVRF (VRF c)) -> Down (OutputVRF (VRF c)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Down (OutputVRF (VRF c)) -> Down (OutputVRF (VRF c)) -> Ordering)
-> (PraosTiebreakerView c -> Down (OutputVRF (VRF c)))
-> PraosTiebreakerView c
-> PraosTiebreakerView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OutputVRF (VRF c) -> Down (OutputVRF (VRF c))
forall a. a -> Down a
Down (OutputVRF (VRF c) -> Down (OutputVRF (VRF c)))
-> (PraosTiebreakerView c -> OutputVRF (VRF c))
-> PraosTiebreakerView c
-> Down (OutputVRF (VRF c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PraosTiebreakerView c -> OutputVRF (VRF c)
forall c. PraosTiebreakerView c -> OutputVRF (VRF c)
ptvTieBreakVRF)
 where
  -- When the predicate @p@ returns 'True', use the given comparison function,
  -- otherwise, no preference.
  when' ::
    (a -> a -> Bool) ->
    (a -> a -> Ordering) ->
    (a -> a -> Ordering)
  when' :: forall a.
(a -> a -> Bool) -> (a -> a -> Ordering) -> a -> a -> Ordering
when' a -> a -> Bool
p a -> a -> Ordering
comp a
a1 a
a2 =
    if a -> a -> Bool
p a
a1 a
a2 then a -> a -> Ordering
comp a
a1 a
a2 else Ordering
EQ

  -- Only compare the issue numbers when the issuers and slots are identical.
  -- Note that this case implies the VRFs also coincide.
  issueNoArmed :: PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
issueNoArmed PraosTiebreakerView c
v1 PraosTiebreakerView c
v2 =
    PraosTiebreakerView c -> SlotNo
forall c. PraosTiebreakerView c -> SlotNo
ptvSlotNo PraosTiebreakerView c
v1 SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== PraosTiebreakerView c -> SlotNo
forall c. PraosTiebreakerView c -> SlotNo
ptvSlotNo PraosTiebreakerView c
v2
      Bool -> Bool -> Bool
&& PraosTiebreakerView c -> VKey 'BlockIssuer
forall c. PraosTiebreakerView c -> VKey 'BlockIssuer
ptvIssuer PraosTiebreakerView c
v1 VKey 'BlockIssuer -> VKey 'BlockIssuer -> Bool
forall a. Eq a => a -> a -> Bool
== PraosTiebreakerView c -> VKey 'BlockIssuer
forall c. PraosTiebreakerView c -> VKey 'BlockIssuer
ptvIssuer PraosTiebreakerView c
v2

  -- Whether to do a VRF comparison.
  vrfArmed :: PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
vrfArmed PraosTiebreakerView c
v1 PraosTiebreakerView c
v2 = case VRFTiebreakerFlavor
tiebreakerFlavor of
    VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker -> Bool
True
    RestrictedVRFTiebreaker SlotNo
maxDist ->
      SlotNo -> SlotNo -> SlotNo
slotDist (PraosTiebreakerView c -> SlotNo
forall c. PraosTiebreakerView c -> SlotNo
ptvSlotNo PraosTiebreakerView c
v1) (PraosTiebreakerView c -> SlotNo
forall c. PraosTiebreakerView c -> SlotNo
ptvSlotNo PraosTiebreakerView c
v2) SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
maxDist

  slotDist :: SlotNo -> SlotNo -> SlotNo
  slotDist :: SlotNo -> SlotNo -> SlotNo
slotDist SlotNo
s SlotNo
t
    -- slot numbers are unsigned, so have to take care with subtraction
    | SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
t = SlotNo
s SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
t
    | Bool
otherwise = SlotNo
t SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
s

-- | We order between chains of equal length as follows:
--
-- 1. If the tip of each chain was issued by the same agent and they have the
--    same slot number, prefer the chain whose tip has the highest ocert issue
--    number.
--
-- 2. By a VRF value from the chain tip, with lower values preferred. See
--    @pTieBreakVRFValue@ for which one is used.
--
-- IMPORTANT: This is not a complete picture of the Praos chain order, do also
-- consult the documentation of 'ChainOrder'.
instance Crypto c => Ord (PraosTiebreakerView c) where
  compare :: PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
compare = VRFTiebreakerFlavor
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
forall c.
VRFTiebreakerFlavor
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
comparePraos VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker

-- | IMPORTANT: This is not a 'SimpleChainOrder'; rather, there are
-- 'PraosTiebreakerView's @a, b@ such that @a < b@, but @'not' $
-- 'preferCandidate' cfg a b@, namely for @cfg = 'RestrictedVRFTiebreaker'@.
--
-- === Rules
--
-- Concretely, we have @'preferCandidate' cfg ours cand@ (where @ours@ and
-- @cand@ have equal length) based on the following lexicographical criteria:
--
-- 1. If the tip of each chain was issued by the same agent and had the same
--    slot number, then we prefer the candidate if it has a higher ocert issue
--    number.
--
--     Note that this condition is equivalent to the VRFs being identical, as
--     the VRF is a deterministic function of the issuer VRF key, the slot and
--     the epoch nonce, and VRFs are collision-resistant.
--
-- 2. Depending on the 'VRFTiebreakerFlavor':
--
--     * If 'UnrestrictedVRFTiebreaker': Compare via a VRF value from the chain
--       tip, with lower values preferred. See @pTieBreakVRFValue@ for which one
--       is used.
--
--     * If @'RestrictedVRFTiebreaker' maxDist@: Only do the VRF comparison (as
--       in the previous step) if the slot numbers differ by at most @maxDist@.
--
-- === Non-transitivity of 'RestrictedVRFTiebreaker'
--
-- When using @cfg = 'RestrictedVRFTiebreaker' maxDist@, the chain order is not
-- transitive. As an example, suppose @maxDist = 5@ and consider three
-- 'PraosTiebreakerView's with pairwise different issuers and, as well as
--
-- +------+---+---+---+
-- |      | a | b | c |
-- +======+===+===+===+
-- | Slot | 0 | 3 | 6 |
-- +------+---+---+---+
-- | VRF  | 3 | 2 | 1 |
-- +------+---+---+---+
--
-- Then we have @'preferCandidate' cfg a b@ and @'preferCandidate' b c@, but
-- __not__ @'preferCandidate' a c@ (despite @a < c@).
--
-- === Rationale for the rules
--
-- 1. Consider the scenario where the hot key of a block issuer was compromised,
--    and the attacker is now minting blocks using that identity. The actual
--    block issuer can use their cold key to issue a new hot key with a higher
--    opcert issue number and set up a new pool. Due to this tiebreaker rule,
--    the blocks minted by that pool will take precedence (allowing the actual
--    block issuer to decide on eg the block contents and the predecessor) over
--    blocks with the same block and slot number minted by the attacker, and
--    they will end up on the honest chain quickly, which means that the
--    adversary can't extend any chain containing such a block as it would
--    violate the monotonicity requirement on opcert issue numbers.
--
--     See "3.7 Block Validity and Operational Key Certificates" in "Design
--     Specification for Delegation and Incentives in Cardano" by Kant et al for
--     more context.
--
-- 2. The main motivation to do VRF comparisons is to avoid the "Frankfurt
--    problem":
--
--     With only the first two rules for the chain order, almost all blocks with
--     equal block number are equally preferrable. Consider two block issuers
--     minting blocks in very nearby slots. As we never change our selection
--     from one chain to an equally preferrable one, the first block to arrive
--     at another pool is the one to be adopted, and will be extended the next
--     time the pool is elected if no blocks with a higher block number arrive
--     in the meantime. We observed that this effectively incentivizes block
--     producers to concentrate geographically (historically, in Frankfurt) in
--     order to minimize their diffusion times. This works against the goal of
--     geographic decentralisation.
--
--     Also, with the VRF tiebreaker, a block with a somewhat lower propagation
--     speed has a random chance to be selected instead of the one that arrived
--     first by pools before the next block is forged.
--
--     See 'VRFTiebreakerFlavor' for more context on the exact conditions under
--     which the VRF comparison takes place.
instance Crypto c => ChainOrder (PraosTiebreakerView c) where
  type ChainOrderConfig (PraosTiebreakerView c) = VRFTiebreakerFlavor

  preferCandidate :: ChainOrderConfig (PraosTiebreakerView c)
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Bool
preferCandidate ChainOrderConfig (PraosTiebreakerView c)
cfg PraosTiebreakerView c
ours PraosTiebreakerView c
cand = VRFTiebreakerFlavor
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
forall c.
VRFTiebreakerFlavor
-> PraosTiebreakerView c -> PraosTiebreakerView c -> Ordering
comparePraos ChainOrderConfig (PraosTiebreakerView c)
VRFTiebreakerFlavor
cfg PraosTiebreakerView c
ours PraosTiebreakerView c
cand Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT

data PraosCanBeLeader c = PraosCanBeLeader
  { forall c. PraosCanBeLeader c -> VKey 'BlockIssuer
praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer)
  -- ^ Stake pool cold key or genesis stakeholder delegate cold key.
  , forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: !(SignKeyVRF (VRF c))
  , forall c. PraosCanBeLeader c -> PraosCredentialsSource c
praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c)
  -- ^ How to obtain KES credentials (ocert + sign key)
  }
  deriving (forall x. PraosCanBeLeader c -> Rep (PraosCanBeLeader c) x)
-> (forall x. Rep (PraosCanBeLeader c) x -> PraosCanBeLeader c)
-> Generic (PraosCanBeLeader c)
forall x. Rep (PraosCanBeLeader c) x -> PraosCanBeLeader c
forall x. PraosCanBeLeader c -> Rep (PraosCanBeLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosCanBeLeader c) x -> PraosCanBeLeader c
forall c x. PraosCanBeLeader c -> Rep (PraosCanBeLeader c) x
$cfrom :: forall c x. PraosCanBeLeader c -> Rep (PraosCanBeLeader c) x
from :: forall x. PraosCanBeLeader c -> Rep (PraosCanBeLeader c) x
$cto :: forall c x. Rep (PraosCanBeLeader c) x -> PraosCanBeLeader c
to :: forall x. Rep (PraosCanBeLeader c) x -> PraosCanBeLeader c
Generic

instance
  (NoThunks (SignKeyVRF (VRF c)), NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) =>
  NoThunks (PraosCanBeLeader c)

-- | Defines a method for obtaining Praos credentials (opcert + KES signing
-- key).
data PraosCredentialsSource c where
  -- | Pass an opcert and sign key directly. This uses
  -- 'KES.UnsoundPureSignKeyKES', which does not provide mlocking guarantees,
  -- violating the rule that KES secrets must never be stored on disk, but
  -- allows the sign key to be loaded from a local file. This method is
  -- provided for backwards compatibility.
  PraosCredentialsUnsound ::
    OCert.OCert c -> KES.UnsoundPureSignKeyKES (KES c) -> PraosCredentialsSource c
  -- | Connect to a KES agent listening on a service socket at the given path.
  PraosCredentialsAgent ::
    Agent.DSIGN (ACrypto c) ~ DSIGN => Void -> FilePath -> PraosCredentialsSource c

instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCredentialsSource c) where
  wNoThunks :: Context -> PraosCredentialsSource c -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = \case
    PraosCredentialsUnsound OCert c
oca UnsoundPureSignKeyKES (KES c)
k ->
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks
        [ Context -> OCert c -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt OCert c
oca
        , Context -> UnsoundPureSignKeyKES (KES c) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt UnsoundPureSignKeyKES (KES c)
k
        ]
    PraosCredentialsAgent Void
_ String
fp -> Context -> String -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt String
fp

  showTypeOf :: Proxy (PraosCredentialsSource c) -> String
showTypeOf Proxy (PraosCredentialsSource c)
_ = String
"PraosCredentialsSource"

instantiatePraosCredentials ::
  forall m c.
  KESAgentContext c m =>
  Word64 ->
  Tracer.Tracer m KESAgentClientTrace ->
  PraosCredentialsSource c ->
  m (HotKey.HotKey c m)
instantiatePraosCredentials :: forall (m :: * -> *) c.
KESAgentContext c m =>
Word64
-> Tracer m KESAgentClientTrace
-> PraosCredentialsSource c
-> m (HotKey c m)
instantiatePraosCredentials Word64
maxKESEvolutions Tracer m KESAgentClientTrace
_ (PraosCredentialsUnsound OCert c
ocert UnsoundPureSignKeyKES (KES c)
skUnsound) = do
  sk <- UnsoundPureSignKeyKES (KES c) -> m (SignKeyKES (KES c))
forall v (m :: * -> *).
(UnsoundPureKESAlgorithm v, MonadST m, MonadThrow m) =>
UnsoundPureSignKeyKES v -> m (SignKeyKES v)
forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
UnsoundPureSignKeyKES (KES c) -> m (SignKeyKES (KES c))
KES.unsoundPureSignKeyKESToSoundSignKeyKES UnsoundPureSignKeyKES (KES c)
skUnsound
  let startPeriod :: OCert.KESPeriod
      startPeriod = OCert c -> KESPeriod
forall c. OCert c -> KESPeriod
OCert.ocertKESPeriod OCert c
ocert

  HotKey.mkHotKey
    ocert
    sk
    startPeriod
    maxKESEvolutions
instantiatePraosCredentials Word64
maxKESEvolutions Tracer m KESAgentClientTrace
tr (PraosCredentialsAgent Void
_ String
path) = do
  Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
HotKey.mkDynamicHotKey
    Word64
maxKESEvolutions
    (KeyProducer c m -> Maybe (KeyProducer c m)
forall a. a -> Maybe a
Just (KeyProducer c m -> Maybe (KeyProducer c m))
-> KeyProducer c m -> Maybe (KeyProducer c m)
forall a b. (a -> b) -> a -> b
$ Tracer m KESAgentClientTrace -> String -> KeyProducer c m
forall (m :: * -> *) c.
(KESAgentContext c m, DSIGN (ACrypto c) ~ DSIGN) =>
Tracer m KESAgentClientTrace
-> String
-> (OCert c -> SignKeyKES (KES c) -> Word -> KESPeriod -> m ())
-> m ()
-> m ()
runKESAgentClient Tracer m KESAgentClientTrace
tr String
path)

-- | See 'PraosProtocolSupportsNode'
data PraosNonces = PraosNonces
  { PraosNonces -> Nonce
candidateNonce :: !Nonce
  , PraosNonces -> Nonce
epochNonce :: !Nonce
  , PraosNonces -> Nonce
evolvingNonce :: !Nonce
  , PraosNonces -> Nonce
labNonce :: !Nonce
  -- ^ Nonce constructed from the hash of the Last Applied Block
  , PraosNonces -> Nonce
previousLabNonce :: !Nonce
  -- ^ Nonce corresponding to the LAB nonce of the last block of the previous
  -- epoch
  }

-- | The node has Praos-aware code that inspects nonces in order to support
-- some Cardano API queries that are crucial to the user exprience
--
-- The interface being used for that has grown and needs review, but we're
-- adding to it here under time pressure. See
-- <https://github.com/IntersectMBO/cardano-node/issues/3864>
class ConsensusProtocol p => PraosProtocolSupportsNode p where
  type PraosProtocolSupportsNodeCrypto p

  getPraosNonces :: proxy p -> ChainDepState p -> PraosNonces

  getOpCertCounters :: proxy p -> ChainDepState p -> Map (KeyHash 'BlockIssuer) Word64