{-# 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 (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
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)