{-# 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 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 (ProtoCrypto (TPraos c))
pHeaderHash = Hash c EraIndependentBlockHeader -> ShelleyHash c
forall crypto.
Hash crypto EraIndependentBlockHeader -> ShelleyHash crypto
ShelleyHash (Hash c EraIndependentBlockHeader -> ShelleyHash c)
-> (BHeader c -> Hash c EraIndependentBlockHeader)
-> BHeader c
-> ShelleyHash c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashHeader c -> Hash c EraIndependentBlockHeader
forall c. HashHeader c -> Hash c EraIndependentBlockHeader
SL.unHashHeader (HashHeader c -> Hash c EraIndependentBlockHeader)
-> (BHeader c -> HashHeader c)
-> BHeader c
-> Hash c EraIndependentBlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> HashHeader c
forall c. Crypto c => BHeader c -> HashHeader c
SL.bhHash
  pHeaderPrevHash :: ShelleyProtocolHeader (TPraos c)
-> PrevHash (ProtoCrypto (TPraos c))
pHeaderPrevHash = BHBody c -> PrevHash c
forall c. BHBody c -> PrevHash c
SL.bheaderPrev (BHBody c -> PrevHash c)
-> (BHeader c -> BHBody c) -> BHeader c -> PrevHash 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
  pHeaderBodyHash :: ShelleyProtocolHeader (TPraos c)
-> Hash (ProtoCrypto (TPraos c)) EraIndependentBlockBody
pHeaderBodyHash = BHBody c -> Hash c EraIndependentBlockBody
forall c. BHBody c -> Hash c EraIndependentBlockBody
SL.bhash (BHBody c -> Hash c EraIndependentBlockBody)
-> (BHeader c -> BHBody c)
-> BHeader c
-> Hash c 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 c. BHeader c -> Int
SL.bHeaderSize
  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 c
-> ExceptT ChainPredicateFailure Identity ()
forall c (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView c -> m ()
SL.chainChecks
      Version
maxPV
      (LedgerView c -> ChainChecksPParams
forall c. LedgerView c -> ChainChecksPParams
SL.lvChainChecks LedgerView c
LedgerView (TPraos c)
lv)
      (BHeader c -> BHeaderView c
forall c. Crypto c => BHeader c -> BHeaderView c
SL.makeHeaderView (BHeader c -> BHeaderView c) -> BHeader c -> BHeaderView c
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 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 crypto
-> Hash crypto 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 crypto
prevHash Hash crypto EraIndependentBlockBody
bbHash Int
actualBodySize ProtVer
protVer = do
    TPraosFields {SignedKES crypto (BHBody crypto)
tpraosSignature :: SignedKES crypto (BHBody crypto)
tpraosSignature :: forall c toSign. TPraosFields c toSign -> SignedKES c toSign
tpraosSignature, BHBody crypto
tpraosToSign :: BHBody crypto
tpraosToSign :: forall c toSign. TPraosFields c toSign -> toSign
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, KESignable 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
    BHeader crypto -> m (BHeader crypto)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BHeader crypto -> m (BHeader crypto))
-> BHeader crypto -> m (BHeader crypto)
forall a b. (a -> b) -> a -> b
$ BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
forall c.
Crypto c =>
BHBody c -> SignedKES c (BHBody c) -> BHeader c
SL.BHeader BHBody crypto
tpraosToSign SignedKES crypto (BHBody crypto)
tpraosSignature
    where
      mkBhBody :: TPraosToSign crypto -> BHBody crypto
mkBhBody TPraosToSign crypto
toSign =
        SL.BHBody
          { bheaderPrev :: PrevHash crypto
SL.bheaderPrev = PrevHash crypto
prevHash,
            bheaderVk :: VKey 'BlockIssuer crypto
SL.bheaderVk = VKey 'BlockIssuer crypto
tpraosToSignIssuerVK,
            bheaderVrfVk :: VerKeyVRF crypto
SL.bheaderVrfVk = VerKeyVRF crypto
tpraosToSignVrfVK,
            bheaderSlotNo :: SlotNo
SL.bheaderSlotNo = SlotNo
curSlot,
            bheaderBlockNo :: BlockNo
SL.bheaderBlockNo = BlockNo
curNo,
            bheaderEta :: CertifiedVRF crypto Nonce
SL.bheaderEta = CertifiedVRF crypto Nonce
tpraosToSignEta,
            bheaderL :: CertifiedVRF crypto Natural
SL.bheaderL = CertifiedVRF crypto Natural
tpraosToSignLeader,
            bsize :: Word32
SL.bsize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
actualBodySize,
            bhash :: Hash crypto EraIndependentBlockBody
SL.bhash = Hash crypto EraIndependentBlockBody
bbHash,
            bheaderOCert :: OCert crypto
SL.bheaderOCert = OCert crypto
tpraosToSignOCert,
            bprotver :: ProtVer
SL.bprotver = ProtVer
protVer
          }
        where
          TPraosToSign
            { VKey 'BlockIssuer crypto
tpraosToSignIssuerVK :: VKey 'BlockIssuer crypto
tpraosToSignIssuerVK :: forall c. TPraosToSign c -> VKey 'BlockIssuer c
tpraosToSignIssuerVK,
              VerKeyVRF crypto
tpraosToSignVrfVK :: VerKeyVRF crypto
tpraosToSignVrfVK :: forall c. TPraosToSign c -> VerKeyVRF c
tpraosToSignVrfVK,
              CertifiedVRF crypto Nonce
tpraosToSignEta :: CertifiedVRF crypto Nonce
tpraosToSignEta :: forall c. TPraosToSign c -> CertifiedVRF c Nonce
tpraosToSignEta,
              CertifiedVRF crypto Natural
tpraosToSignLeader :: CertifiedVRF crypto Natural
tpraosToSignLeader :: forall c. TPraosToSign c -> CertifiedVRF 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 (ProtoCrypto (TPraos c))
pHeaderIssuer = BHBody c -> VKey 'BlockIssuer c
forall c. BHBody c -> VKey 'BlockIssuer c
SL.bheaderVk (BHBody c -> VKey 'BlockIssuer c)
-> (BHeader c -> BHBody c) -> BHeader c -> VKey 'BlockIssuer 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
  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 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 (ProtoCrypto (TPraos c))
mkHeaderView = BHeader c -> BHeaderView c
ShelleyProtocolHeader (TPraos c)
-> BHeaderView (ProtoCrypto (TPraos c))
forall c. Crypto c => BHeader c -> BHeaderView c
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)