{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Protocol.TPraos () where

import qualified Cardano.Crypto.KES as SL
import           Cardano.Crypto.VRF (certifiedOutput)
import           Cardano.Ledger.Chain (ChainPredicateFailure)
import           Cardano.Ledger.Hashes (originalBytesSize)
import qualified Cardano.Ledger.Shelley.API as SL
import           Cardano.Protocol.TPraos.API (PraosCrypto)
import qualified Cardano.Protocol.TPraos.API as SL
import qualified Cardano.Protocol.TPraos.BHeader as SL
import           Cardano.Protocol.TPraos.OCert (ocertKESPeriod, ocertVkHot)
import qualified Cardano.Protocol.TPraos.OCert as SL
import           Cardano.Slotting.Slot (unSlotNo)
import           Data.Either (isRight)
import           Data.Word (Word32)
import           Numeric.Natural (Natural)
import           Ouroboros.Consensus.Protocol.Signed (Signed,
                     SignedHeader (headerSigned))
import           Ouroboros.Consensus.Protocol.TPraos
                     (MaxMajorProtVer (MaxMajorProtVer), TPraos,
                     TPraosCannotForge, TPraosFields (..), TPraosToSign (..),
                     forgeTPraosFields, tpraosMaxMajorPV, tpraosParams,
                     tpraosSlotsPerKESPeriod)
import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto,
                     ProtocolHeaderSupportsEnvelope (..),
                     ProtocolHeaderSupportsKES (..),
                     ProtocolHeaderSupportsLedger (..),
                     ProtocolHeaderSupportsProtocol (..), ShelleyHash (..),
                     ShelleyProtocol, ShelleyProtocolHeader, protocolHeaderView)

type instance ProtoCrypto (TPraos c) = c

type instance ShelleyProtocolHeader (TPraos c) = SL.BHeader c

instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where
  pHeaderHash :: ShelleyProtocolHeader (TPraos c) -> ShelleyHash
pHeaderHash = Hash HASH EraIndependentBlockHeader -> ShelleyHash
ShelleyHash (Hash HASH EraIndependentBlockHeader -> ShelleyHash)
-> (BHeader c -> Hash HASH EraIndependentBlockHeader)
-> BHeader c
-> ShelleyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashHeader -> Hash HASH EraIndependentBlockHeader
SL.unHashHeader (HashHeader -> Hash HASH EraIndependentBlockHeader)
-> (BHeader c -> HashHeader)
-> BHeader c
-> Hash HASH EraIndependentBlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> HashHeader
forall c. BHeader c -> HashHeader
SL.bhHash
  pHeaderPrevHash :: ShelleyProtocolHeader (TPraos c) -> PrevHash
pHeaderPrevHash = BHBody c -> PrevHash
forall c. BHBody c -> PrevHash
SL.bheaderPrev (BHBody c -> PrevHash)
-> (BHeader c -> BHBody c) -> BHeader c -> PrevHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody
  pHeaderBodyHash :: ShelleyProtocolHeader (TPraos c)
-> Hash HASH EraIndependentBlockBody
pHeaderBodyHash = BHBody c -> Hash HASH EraIndependentBlockBody
forall c. BHBody c -> Hash HASH EraIndependentBlockBody
SL.bhash (BHBody c -> Hash HASH EraIndependentBlockBody)
-> (BHeader c -> BHBody c)
-> BHeader c
-> Hash HASH EraIndependentBlockBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody
  pHeaderSlot :: ShelleyProtocolHeader (TPraos c) -> SlotNo
pHeaderSlot = BHBody c -> SlotNo
forall c. BHBody c -> SlotNo
SL.bheaderSlotNo (BHBody c -> SlotNo)
-> (BHeader c -> BHBody c) -> BHeader c -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody
  pHeaderBlock :: ShelleyProtocolHeader (TPraos c) -> BlockNo
pHeaderBlock = BHBody c -> BlockNo
forall c. BHBody c -> BlockNo
SL.bheaderBlockNo (BHBody c -> BlockNo)
-> (BHeader c -> BHBody c) -> BHeader c -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody
  pHeaderSize :: ShelleyProtocolHeader (TPraos c) -> Natural
pHeaderSize = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> (BHeader c -> Int) -> BHeader c -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize
  pHeaderBlockSize :: ShelleyProtocolHeader (TPraos c) -> Natural
pHeaderBlockSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Natural (Word32 -> Natural)
-> (BHeader c -> Word32) -> BHeader c -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody c -> Word32
forall c. BHBody c -> Word32
SL.bsize (BHBody c -> Word32)
-> (BHeader c -> BHBody c) -> BHeader c -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody

  type EnvelopeCheckError _ = ChainPredicateFailure

  envelopeChecks :: ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> ShelleyProtocolHeader (TPraos c)
-> Except (EnvelopeCheckError (TPraos c)) ()
envelopeChecks ConsensusConfig (TPraos c)
cfg LedgerView (TPraos c)
lv ShelleyProtocolHeader (TPraos c)
hdr =
    Version
-> ChainChecksPParams
-> BHeaderView
-> ExceptT ChainPredicateFailure Identity ()
forall (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView -> m ()
SL.chainChecks
      Version
maxPV
      (LedgerView -> ChainChecksPParams
SL.lvChainChecks LedgerView
LedgerView (TPraos c)
lv)
      (BHeader c -> BHeaderView
forall c. Crypto c => BHeader c -> BHeaderView
SL.makeHeaderView (BHeader c -> BHeaderView) -> BHeader c -> BHeaderView
forall a b. (a -> b) -> a -> b
$ forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> ValidateView proto
protocolHeaderView @(TPraos c) ShelleyProtocolHeader (TPraos c)
hdr)
    where
      MaxMajorProtVer Version
maxPV = TPraosParams -> MaxMajorProtVer
tpraosMaxMajorPV (TPraosParams -> MaxMajorProtVer)
-> TPraosParams -> MaxMajorProtVer
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (TPraos c) -> TPraosParams
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams ConsensusConfig (TPraos c)
cfg

instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where
  configSlotsPerKESPeriod :: ConsensusConfig (TPraos c) -> Word64
configSlotsPerKESPeriod ConsensusConfig (TPraos c)
cfg = TPraosParams -> Word64
tpraosSlotsPerKESPeriod (TPraosParams -> Word64) -> TPraosParams -> Word64
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (TPraos c) -> TPraosParams
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams ConsensusConfig (TPraos c)
cfg
  verifyHeaderIntegrity :: Word64 -> ShelleyProtocolHeader (TPraos c) -> Bool
verifyHeaderIntegrity Word64
slotsPerKESPeriod ShelleyProtocolHeader (TPraos c)
hdr =
    Either String () -> Bool
forall a b. Either a b -> Bool
isRight (Either String () -> Bool) -> Either String () -> Bool
forall a b. (a -> b) -> a -> b
$ ContextKES (KES c)
-> VerKeyKES (KES c)
-> Word
-> BHBody c
-> SignedKES (KES c) (BHBody c)
-> Either String ()
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v
-> VerKeyKES v -> Word -> a -> SignedKES v a -> Either String ()
SL.verifySignedKES () VerKeyKES (KES c)
ocertVkHot Word
t BHBody c
hdrBody SignedKES (KES c) (BHBody c)
hdrSignature
    where
      SL.BHeader BHBody c
hdrBody SignedKES (KES c) (BHBody c)
hdrSignature = ShelleyProtocolHeader (TPraos c)
hdr
      SL.OCert
        { VerKeyKES (KES c)
ocertVkHot :: forall c. OCert c -> VerKeyKES (KES c)
ocertVkHot :: VerKeyKES (KES c)
ocertVkHot,
          ocertKESPeriod :: forall c. OCert c -> KESPeriod
ocertKESPeriod = SL.KESPeriod Word
startOfKesPeriod
        } = BHBody c -> OCert c
forall c. BHBody c -> OCert c
SL.bheaderOCert BHBody c
hdrBody

      currentKesPeriod :: Word
currentKesPeriod =
        Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Word64 -> Word
forall a b. (a -> b) -> a -> b
$
          SlotNo -> Word64
unSlotNo (BHBody c -> SlotNo
forall c. BHBody c -> SlotNo
SL.bheaderSlotNo (BHBody c -> SlotNo) -> BHBody c -> SlotNo
forall a b. (a -> b) -> a -> b
$ BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody BHeader c
ShelleyProtocolHeader (TPraos c)
hdr) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
slotsPerKESPeriod

      t :: Word
t
        | Word
currentKesPeriod Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
startOfKesPeriod =
          Word
currentKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
startOfKesPeriod
        | Bool
otherwise =
          Word
0
  mkHeader :: forall crypto (m :: * -> *).
(Crypto crypto, Monad m, crypto ~ ProtoCrypto (TPraos c)) =>
HotKey crypto m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> SlotNo
-> BlockNo
-> PrevHash
-> Hash HASH EraIndependentBlockBody
-> Int
-> ProtVer
-> m (ShelleyProtocolHeader (TPraos c))
mkHeader HotKey crypto m
hotKey CanBeLeader (TPraos c)
canBeLeader IsLeader (TPraos c)
isLeader SlotNo
curSlot BlockNo
curNo PrevHash
prevHash Hash HASH EraIndependentBlockBody
bbHash Int
actualBodySize ProtVer
protVer = do
    TPraosFields {tpraosSignature, tpraosToSign} <-
      HotKey crypto m
-> CanBeLeader (TPraos crypto)
-> IsLeader (TPraos crypto)
-> (TPraosToSign crypto -> BHBody crypto)
-> m (TPraosFields crypto (BHBody crypto))
forall c toSign (m :: * -> *).
(PraosCrypto c, Signable (KES c) toSign, Monad m) =>
HotKey c m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> (TPraosToSign c -> toSign)
-> m (TPraosFields c toSign)
forgeTPraosFields HotKey crypto m
hotKey CanBeLeader (TPraos c)
CanBeLeader (TPraos crypto)
canBeLeader IsLeader (TPraos c)
IsLeader (TPraos crypto)
isLeader TPraosToSign crypto -> BHBody crypto
mkBhBody
    pure $ SL.BHeader tpraosToSign tpraosSignature
    where
      mkBhBody :: TPraosToSign crypto -> BHBody crypto
mkBhBody TPraosToSign crypto
toSign =
        SL.BHBody
          { bheaderPrev :: PrevHash
SL.bheaderPrev = PrevHash
prevHash,
            bheaderVk :: VKey 'BlockIssuer
SL.bheaderVk = VKey 'BlockIssuer
tpraosToSignIssuerVK,
            bheaderVrfVk :: VerKeyVRF (VRF crypto)
SL.bheaderVrfVk = VerKeyVRF (VRF crypto)
tpraosToSignVrfVK,
            bheaderSlotNo :: SlotNo
SL.bheaderSlotNo = SlotNo
curSlot,
            bheaderBlockNo :: BlockNo
SL.bheaderBlockNo = BlockNo
curNo,
            bheaderEta :: CertifiedVRF (VRF crypto) Nonce
SL.bheaderEta = CertifiedVRF (VRF crypto) Nonce
tpraosToSignEta,
            bheaderL :: CertifiedVRF (VRF crypto) Natural
SL.bheaderL = CertifiedVRF (VRF crypto) Natural
tpraosToSignLeader,
            bsize :: Word32
SL.bsize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
actualBodySize,
            bhash :: Hash HASH EraIndependentBlockBody
SL.bhash = Hash HASH EraIndependentBlockBody
bbHash,
            bheaderOCert :: OCert crypto
SL.bheaderOCert = OCert crypto
tpraosToSignOCert,
            bprotver :: ProtVer
SL.bprotver = ProtVer
protVer
          }
        where
          TPraosToSign
            { VKey 'BlockIssuer
tpraosToSignIssuerVK :: VKey 'BlockIssuer
tpraosToSignIssuerVK :: forall c. TPraosToSign c -> VKey 'BlockIssuer
tpraosToSignIssuerVK,
              VerKeyVRF (VRF crypto)
tpraosToSignVrfVK :: VerKeyVRF (VRF crypto)
tpraosToSignVrfVK :: forall c. TPraosToSign c -> VerKeyVRF (VRF c)
tpraosToSignVrfVK,
              CertifiedVRF (VRF crypto) Nonce
tpraosToSignEta :: CertifiedVRF (VRF crypto) Nonce
tpraosToSignEta :: forall c. TPraosToSign c -> CertifiedVRF (VRF c) Nonce
tpraosToSignEta,
              CertifiedVRF (VRF crypto) Natural
tpraosToSignLeader :: CertifiedVRF (VRF crypto) Natural
tpraosToSignLeader :: forall c. TPraosToSign c -> CertifiedVRF (VRF c) Natural
tpraosToSignLeader,
              OCert crypto
tpraosToSignOCert :: OCert crypto
tpraosToSignOCert :: forall c. TPraosToSign c -> OCert c
tpraosToSignOCert
            } = TPraosToSign crypto
toSign

instance PraosCrypto c => ProtocolHeaderSupportsProtocol (TPraos c) where
  type CannotForgeError (TPraos c) = TPraosCannotForge c

  protocolHeaderView :: ShelleyProtocolHeader (TPraos c) -> ValidateView (TPraos c)
protocolHeaderView = BHeader c -> BHeader c
ShelleyProtocolHeader (TPraos c) -> ValidateView (TPraos c)
forall a. a -> a
id
  pHeaderIssuer :: ShelleyProtocolHeader (TPraos c) -> VKey 'BlockIssuer
pHeaderIssuer = BHBody c -> VKey 'BlockIssuer
forall c. BHBody c -> VKey 'BlockIssuer
SL.bheaderVk (BHBody c -> VKey 'BlockIssuer)
-> (BHeader c -> BHBody c) -> BHeader c -> VKey 'BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody
  pHeaderIssueNo :: ShelleyProtocolHeader (TPraos c) -> Word64
pHeaderIssueNo = OCert c -> Word64
forall c. OCert c -> Word64
SL.ocertN (OCert c -> Word64)
-> (BHeader c -> OCert c) -> BHeader c -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody c -> OCert c
forall c. BHBody c -> OCert c
SL.bheaderOCert (BHBody c -> OCert c)
-> (BHeader c -> BHBody c) -> BHeader c -> OCert c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody

  -- As this is the leader VRF value, which is used for slot election in the
  -- first place, it gives an advantage to smaller pools in a multi-leader slot.
  -- This was not an intentional decision, see
  -- https://github.com/IntersectMBO/ouroboros-network/issues/4051 for a more
  -- detailed discussion.
  pTieBreakVRFValue :: ShelleyProtocolHeader (TPraos c)
-> OutputVRF (VRF (ProtoCrypto (TPraos c)))
pTieBreakVRFValue = CertifiedVRF (VRF c) Natural -> OutputVRF (VRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
certifiedOutput (CertifiedVRF (VRF c) Natural -> OutputVRF (VRF c))
-> (BHeader c -> CertifiedVRF (VRF c) Natural)
-> BHeader c
-> OutputVRF (VRF c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody c -> CertifiedVRF (VRF c) Natural
forall c. BHBody c -> CertifiedVRF (VRF c) Natural
SL.bheaderL (BHBody c -> CertifiedVRF (VRF c) Natural)
-> (BHeader c -> BHBody c)
-> BHeader c
-> CertifiedVRF (VRF c) Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody

instance PraosCrypto c => ProtocolHeaderSupportsLedger (TPraos c) where
  mkHeaderView :: ShelleyProtocolHeader (TPraos c) -> BHeaderView
mkHeaderView = BHeader c -> BHeaderView
ShelleyProtocolHeader (TPraos c) -> BHeaderView
forall c. Crypto c => BHeader c -> BHeaderView
SL.makeHeaderView

type instance Signed (SL.BHeader c) = SL.BHBody c

instance PraosCrypto c => SignedHeader (SL.BHeader c) where
  headerSigned :: BHeader c -> Signed (BHeader c)
headerSigned = BHeader c -> BHBody c
BHeader c -> Signed (BHeader c)
forall c. Crypto c => BHeader c -> BHBody c
SL.bhbody

instance PraosCrypto c => ShelleyProtocol (TPraos c)