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

{-# OPTIONS_GHC -Wno-orphans #-}
-- See https://gitlab.haskell.org/ghc/ghc/-/issues/14630. GHC currently warns
-- (erroneously) about name shadowing for record field selectors defined by
-- pattern synonyms. This can be deleted once GHC 8.10.7 is gone.
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Ouroboros.Consensus.Shelley.Protocol.Praos (PraosEnvelopeError (..)) where

import qualified Cardano.Crypto.KES as KES
import           Cardano.Crypto.VRF (certifiedOutput)
import           Cardano.Ledger.BaseTypes (ProtVer (ProtVer), Version)
import           Cardano.Ledger.BHeaderView
import           Cardano.Ledger.Keys (hashKey)
import           Cardano.Ledger.Slot (SlotNo (unSlotNo))
import           Cardano.Protocol.TPraos.OCert
                     (OCert (ocertKESPeriod, ocertVkHot))
import qualified Cardano.Protocol.TPraos.OCert as SL
import           Control.Monad (unless)
import           Control.Monad.Except (throwError)
import           Data.Either (isRight)
import           Data.Word (Word16, Word32)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Protocol.Praos
import           Ouroboros.Consensus.Protocol.Praos.Common
                     (MaxMajorProtVer (MaxMajorProtVer))
import           Ouroboros.Consensus.Protocol.Praos.Header (Header (..),
                     HeaderBody (..), headerHash, headerSize)
import           Ouroboros.Consensus.Protocol.Praos.Views
import           Ouroboros.Consensus.Protocol.Signed
import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto,
                     ProtocolHeaderSupportsEnvelope (..),
                     ProtocolHeaderSupportsKES (..),
                     ProtocolHeaderSupportsLedger (..),
                     ProtocolHeaderSupportsProtocol (..),
                     ShelleyHash (ShelleyHash), ShelleyProtocol,
                     ShelleyProtocolHeader)


type instance ProtoCrypto (Praos c) = c

type instance ShelleyProtocolHeader (Praos c) = Header c

data PraosEnvelopeError
  = ObsoleteNode Version Version
    -- ^ This is a subtle case.
    --
    -- This node is explicitly rejecting the header, but the header isn't
    -- necessarily _directly_ at fault.
    --
    -- This rejection specifically happens when the ticked ledger state being
    -- used to validate this header contains a protocol major version (the
    -- first 'Version') that exceeds the maximum major protocol version allowed
    -- for this era this specific node's configuration (the second 'Version').
    -- The only thing the header did "wrong" was extend such a ledger state.
    --
    -- Note that the ChainSync client ensures that that ledger state is ticked
    -- starting from one of the latest k+1 ledger states on the node's current
    -- chain (modulo STM scheduling).
    --
    -- For Cardano and for now at least, this max major prot ver is typically
    -- hardcoded in the source code (subject only to whether or not the
    -- run-time config files enable "experimental" eras).
    --
    -- Hence, most likely, the appropriate rectifying action is for the node
    -- operator to update their node software and/or config; hence the name
    -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental
    -- era, they forgot to set the appropriate config flag.)
    --
    -- TODO Would it be more intuitive to instead enforce this when validating
    -- the block that results in a ledger state with a major prot ver that
    -- violates the config's limit? Would the errors the user sees be more or
    -- less helpful? Etc.
    --
    -- TODO (cont'd) It's not even obviously that specific ledger
    -- state's/block's fault, since the protocol version is the consequence of
    -- on-chain governance. Is it the voters' fault? Is the fault of the first
    -- block that was after the voting deadline? So "extending the ledger state
    -- that resulting from ticking after applying the block after the epoch
    -- that extended the ancestor block that was after the voting deadline that
    -- ..." is merely one step more removed. And this 'envelopeChecks' approach
    -- does avoid the surprise (since the rejection doesn't even depend on the
    -- block's non-header content either) where the header could be validated
    -- but its underlying block could not. See
    -- <https://github.com/IntersectMBO/ouroboros-consensus/issues/325>.
  | HeaderSizeTooLarge Int Word16
  | BlockSizeTooLarge Word32 Word32
  deriving (PraosEnvelopeError -> PraosEnvelopeError -> Bool
(PraosEnvelopeError -> PraosEnvelopeError -> Bool)
-> (PraosEnvelopeError -> PraosEnvelopeError -> Bool)
-> Eq PraosEnvelopeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PraosEnvelopeError -> PraosEnvelopeError -> Bool
== :: PraosEnvelopeError -> PraosEnvelopeError -> Bool
$c/= :: PraosEnvelopeError -> PraosEnvelopeError -> Bool
/= :: PraosEnvelopeError -> PraosEnvelopeError -> Bool
Eq, (forall x. PraosEnvelopeError -> Rep PraosEnvelopeError x)
-> (forall x. Rep PraosEnvelopeError x -> PraosEnvelopeError)
-> Generic PraosEnvelopeError
forall x. Rep PraosEnvelopeError x -> PraosEnvelopeError
forall x. PraosEnvelopeError -> Rep PraosEnvelopeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PraosEnvelopeError -> Rep PraosEnvelopeError x
from :: forall x. PraosEnvelopeError -> Rep PraosEnvelopeError x
$cto :: forall x. Rep PraosEnvelopeError x -> PraosEnvelopeError
to :: forall x. Rep PraosEnvelopeError x -> PraosEnvelopeError
Generic, Int -> PraosEnvelopeError -> ShowS
[PraosEnvelopeError] -> ShowS
PraosEnvelopeError -> String
(Int -> PraosEnvelopeError -> ShowS)
-> (PraosEnvelopeError -> String)
-> ([PraosEnvelopeError] -> ShowS)
-> Show PraosEnvelopeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PraosEnvelopeError -> ShowS
showsPrec :: Int -> PraosEnvelopeError -> ShowS
$cshow :: PraosEnvelopeError -> String
show :: PraosEnvelopeError -> String
$cshowList :: [PraosEnvelopeError] -> ShowS
showList :: [PraosEnvelopeError] -> ShowS
Show)

instance NoThunks PraosEnvelopeError

instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where
  pHeaderHash :: ShelleyProtocolHeader (Praos c)
-> ShelleyHash (ProtoCrypto (Praos c))
pHeaderHash ShelleyProtocolHeader (Praos c)
hdr = Hash (ProtoCrypto (Praos c)) EraIndependentBlockHeader
-> ShelleyHash (ProtoCrypto (Praos c))
forall crypto.
Hash crypto EraIndependentBlockHeader -> ShelleyHash crypto
ShelleyHash (Hash (ProtoCrypto (Praos c)) EraIndependentBlockHeader
 -> ShelleyHash (ProtoCrypto (Praos c)))
-> Hash (ProtoCrypto (Praos c)) EraIndependentBlockHeader
-> ShelleyHash (ProtoCrypto (Praos c))
forall a b. (a -> b) -> a -> b
$ Header c -> Hash (HASH c) EraIndependentBlockHeader
forall crypto.
Crypto crypto =>
Header crypto -> Hash (HASH crypto) EraIndependentBlockHeader
headerHash Header c
ShelleyProtocolHeader (Praos c)
hdr
  pHeaderPrevHash :: ShelleyProtocolHeader (Praos c) -> PrevHash (ProtoCrypto (Praos c))
pHeaderPrevHash (Header HeaderBody c
body SignedKES c (HeaderBody c)
_) = HeaderBody c -> PrevHash c
forall crypto. HeaderBody crypto -> PrevHash crypto
hbPrev HeaderBody c
body
  pHeaderBodyHash :: ShelleyProtocolHeader (Praos c)
-> Hash (ProtoCrypto (Praos c)) EraIndependentBlockBody
pHeaderBodyHash (Header HeaderBody c
body SignedKES c (HeaderBody c)
_) = HeaderBody c -> Hash c EraIndependentBlockBody
forall crypto.
HeaderBody crypto -> Hash crypto EraIndependentBlockBody
hbBodyHash HeaderBody c
body
  pHeaderSlot :: ShelleyProtocolHeader (Praos c) -> SlotNo
pHeaderSlot (Header HeaderBody c
body SignedKES c (HeaderBody c)
_) = HeaderBody c -> SlotNo
forall crypto. HeaderBody crypto -> SlotNo
hbSlotNo HeaderBody c
body
  pHeaderBlock :: ShelleyProtocolHeader (Praos c) -> BlockNo
pHeaderBlock (Header HeaderBody c
body SignedKES c (HeaderBody c)
_) = HeaderBody c -> BlockNo
forall crypto. HeaderBody crypto -> BlockNo
hbBlockNo HeaderBody c
body
  pHeaderSize :: ShelleyProtocolHeader (Praos c) -> Natural
pHeaderSize ShelleyProtocolHeader (Praos c)
hdr = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Header c -> Int
forall crypto. Header crypto -> Int
headerSize Header c
ShelleyProtocolHeader (Praos c)
hdr
  pHeaderBlockSize :: ShelleyProtocolHeader (Praos c) -> Natural
pHeaderBlockSize (Header HeaderBody c
body SignedKES c (HeaderBody c)
_) = Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Natural) -> Word32 -> Natural
forall a b. (a -> b) -> a -> b
$ HeaderBody c -> Word32
forall crypto. HeaderBody crypto -> Word32
hbBodySize HeaderBody c
body

  type EnvelopeCheckError _ = PraosEnvelopeError

  envelopeChecks :: ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> ShelleyProtocolHeader (Praos c)
-> Except (EnvelopeCheckError (Praos c)) ()
envelopeChecks ConsensusConfig (Praos c)
cfg LedgerView (Praos c)
lv ShelleyProtocolHeader (Praos c)
hdr = do
    Bool
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
m Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
maxpv) (ExceptT PraosEnvelopeError Identity ()
 -> ExceptT PraosEnvelopeError Identity ())
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$ PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ()
forall a.
PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Version -> Version -> PraosEnvelopeError
ObsoleteNode Version
m Version
maxpv)
    Bool
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView c -> Int
forall c. BHeaderView c -> Int
bhviewHSize BHeaderView c
BHeaderView (ProtoCrypto (Praos c))
bhv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int Word16
maxHeaderSize) (ExceptT PraosEnvelopeError Identity ()
 -> ExceptT PraosEnvelopeError Identity ())
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$
      PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ()
forall a.
PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ())
-> PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$
        Int -> Word16 -> PraosEnvelopeError
HeaderSizeTooLarge (BHeaderView c -> Int
forall c. BHeaderView c -> Int
bhviewHSize BHeaderView c
BHeaderView (ProtoCrypto (Praos c))
bhv) Word16
maxHeaderSize
    Bool
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView c -> Word32
forall c. BHeaderView c -> Word32
bhviewBSize BHeaderView c
BHeaderView (ProtoCrypto (Praos c))
bhv Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
maxBodySize) (ExceptT PraosEnvelopeError Identity ()
 -> ExceptT PraosEnvelopeError Identity ())
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$
      PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ()
forall a.
PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ())
-> PraosEnvelopeError -> ExceptT PraosEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$
        Word32 -> Word32 -> PraosEnvelopeError
BlockSizeTooLarge (BHeaderView c -> Word32
forall c. BHeaderView c -> Word32
bhviewBSize BHeaderView c
BHeaderView (ProtoCrypto (Praos c))
bhv) Word32
maxBodySize
    where
      pp :: PraosParams
pp = ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams ConsensusConfig (Praos c)
cfg
      (MaxMajorProtVer Version
maxpv) = PraosParams -> MaxMajorProtVer
praosMaxMajorPV PraosParams
pp
      (ProtVer Version
m Natural
_) = LedgerView c -> ProtVer
forall crypto. LedgerView crypto -> ProtVer
lvProtocolVersion LedgerView (Praos c)
LedgerView c
lv
      maxHeaderSize :: Word16
maxHeaderSize = LedgerView c -> Word16
forall crypto. LedgerView crypto -> Word16
lvMaxHeaderSize LedgerView (Praos c)
LedgerView c
lv
      maxBodySize :: Word32
maxBodySize = LedgerView c -> Word32
forall crypto. LedgerView crypto -> Word32
lvMaxBodySize LedgerView (Praos c)
LedgerView c
lv
      bhv :: BHeaderView (ProtoCrypto (Praos c))
bhv = ShelleyProtocolHeader (Praos c)
-> BHeaderView (ProtoCrypto (Praos c))
forall proto.
ProtocolHeaderSupportsLedger proto =>
ShelleyProtocolHeader proto -> BHeaderView (ProtoCrypto proto)
mkHeaderView ShelleyProtocolHeader (Praos c)
hdr

instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where
  configSlotsPerKESPeriod :: ConsensusConfig (Praos c) -> Word64
configSlotsPerKESPeriod ConsensusConfig (Praos c)
cfg = PraosParams -> Word64
praosSlotsPerKESPeriod (PraosParams -> Word64) -> PraosParams -> Word64
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams ConsensusConfig (Praos c)
cfg
  verifyHeaderIntegrity :: Word64 -> ShelleyProtocolHeader (Praos c) -> Bool
verifyHeaderIntegrity Word64
slotsPerKESPeriod ShelleyProtocolHeader (Praos c)
header =
    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
-> HeaderBody c
-> SignedKES (KES c) (HeaderBody c)
-> Either String ()
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v
-> VerKeyKES v -> Word -> a -> SignedKES v a -> Either String ()
KES.verifySignedKES () VerKeyKES (KES c)
ocertVkHot Word
t HeaderBody c
headerBody SignedKES (KES c) (HeaderBody c)
headerSig
    where
      Header {HeaderBody c
headerBody :: HeaderBody c
headerBody :: forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody, SignedKES (KES c) (HeaderBody c)
headerSig :: SignedKES (KES c) (HeaderBody c)
headerSig :: forall crypto.
Crypto crypto =>
Header crypto -> SignedKES crypto (HeaderBody crypto)
headerSig} = ShelleyProtocolHeader (Praos c)
header
      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
        } = HeaderBody c -> OCert c
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert HeaderBody c
headerBody

      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 (HeaderBody c -> SlotNo
forall crypto. HeaderBody crypto -> SlotNo
hbSlotNo HeaderBody c
headerBody) 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 (Praos c)) =>
HotKey crypto m
-> CanBeLeader (Praos c)
-> IsLeader (Praos c)
-> SlotNo
-> BlockNo
-> PrevHash crypto
-> Hash crypto EraIndependentBlockBody
-> Int
-> ProtVer
-> m (ShelleyProtocolHeader (Praos c))
mkHeader HotKey crypto m
hk CanBeLeader (Praos c)
cbl IsLeader (Praos c)
il SlotNo
slotNo BlockNo
blockNo PrevHash crypto
prevHash Hash crypto EraIndependentBlockBody
bbHash Int
sz ProtVer
protVer = do
    PraosFields {SignedKES crypto (HeaderBody crypto)
praosSignature :: SignedKES crypto (HeaderBody crypto)
praosSignature :: forall c toSign. PraosFields c toSign -> SignedKES c toSign
praosSignature, HeaderBody crypto
praosToSign :: HeaderBody crypto
praosToSign :: forall c toSign. PraosFields c toSign -> toSign
praosToSign} <- HotKey crypto m
-> CanBeLeader (Praos crypto)
-> IsLeader (Praos crypto)
-> (PraosToSign crypto -> HeaderBody crypto)
-> m (PraosFields crypto (HeaderBody crypto))
forall c toSign (m :: * -> *).
(PraosCrypto c, KESignable c toSign, Monad m) =>
HotKey c m
-> CanBeLeader (Praos c)
-> IsLeader (Praos c)
-> (PraosToSign c -> toSign)
-> m (PraosFields c toSign)
forgePraosFields HotKey crypto m
hk CanBeLeader (Praos c)
CanBeLeader (Praos crypto)
cbl IsLeader (Praos c)
IsLeader (Praos crypto)
il PraosToSign crypto -> HeaderBody crypto
mkBhBodyBytes
    Header crypto -> m (Header crypto)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Header crypto -> m (Header crypto))
-> Header crypto -> m (Header crypto)
forall a b. (a -> b) -> a -> b
$ HeaderBody crypto
-> SignedKES crypto (HeaderBody crypto) -> Header crypto
forall crypto.
Crypto crypto =>
HeaderBody crypto
-> SignedKES crypto (HeaderBody crypto) -> Header crypto
Header HeaderBody crypto
praosToSign SignedKES crypto (HeaderBody crypto)
praosSignature
    where
      mkBhBodyBytes :: PraosToSign crypto -> HeaderBody crypto
mkBhBodyBytes
        PraosToSign
          { VKey 'BlockIssuer crypto
praosToSignIssuerVK :: VKey 'BlockIssuer crypto
praosToSignIssuerVK :: forall c. PraosToSign c -> VKey 'BlockIssuer c
praosToSignIssuerVK,
            VerKeyVRF crypto
praosToSignVrfVK :: VerKeyVRF crypto
praosToSignVrfVK :: forall c. PraosToSign c -> VerKeyVRF c
praosToSignVrfVK,
            CertifiedVRF crypto InputVRF
praosToSignVrfRes :: CertifiedVRF crypto InputVRF
praosToSignVrfRes :: forall c. PraosToSign c -> CertifiedVRF c InputVRF
praosToSignVrfRes,
            OCert crypto
praosToSignOCert :: OCert crypto
praosToSignOCert :: forall c. PraosToSign c -> OCert c
praosToSignOCert
          } =
          HeaderBody
            { hbBlockNo :: BlockNo
hbBlockNo = BlockNo
blockNo,
              hbSlotNo :: SlotNo
hbSlotNo = SlotNo
slotNo,
              hbPrev :: PrevHash crypto
hbPrev = PrevHash crypto
prevHash,
              hbVk :: VKey 'BlockIssuer crypto
hbVk = VKey 'BlockIssuer crypto
praosToSignIssuerVK,
              hbVrfVk :: VerKeyVRF crypto
hbVrfVk = VerKeyVRF crypto
praosToSignVrfVK,
              hbVrfRes :: CertifiedVRF crypto InputVRF
hbVrfRes = CertifiedVRF crypto InputVRF
praosToSignVrfRes,
              hbBodySize :: Word32
hbBodySize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz,
              hbBodyHash :: Hash crypto EraIndependentBlockBody
hbBodyHash = Hash crypto EraIndependentBlockBody
bbHash,
              hbOCert :: OCert crypto
hbOCert = OCert crypto
praosToSignOCert,
              hbProtVer :: ProtVer
hbProtVer = ProtVer
protVer
            }

instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where
  type CannotForgeError (Praos c) = PraosCannotForge c
  protocolHeaderView :: ShelleyProtocolHeader (Praos c) -> ValidateView (Praos c)
protocolHeaderView Header {HeaderBody c
headerBody :: forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody :: HeaderBody c
headerBody, SignedKES c (HeaderBody c)
headerSig :: forall crypto.
Crypto crypto =>
Header crypto -> SignedKES crypto (HeaderBody crypto)
headerSig :: SignedKES c (HeaderBody c)
headerSig} =
    HeaderView
      { hvPrevHash :: PrevHash c
hvPrevHash = HeaderBody c -> PrevHash c
forall crypto. HeaderBody crypto -> PrevHash crypto
hbPrev HeaderBody c
headerBody,
        hvVK :: VKey 'BlockIssuer c
hvVK = HeaderBody c -> VKey 'BlockIssuer c
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer crypto
hbVk HeaderBody c
headerBody,
        hvVrfVK :: VerKeyVRF (VRF c)
hvVrfVK = HeaderBody c -> VerKeyVRF (VRF c)
forall crypto. HeaderBody crypto -> VerKeyVRF crypto
hbVrfVk HeaderBody c
headerBody,
        hvVrfRes :: CertifiedVRF (VRF c) InputVRF
hvVrfRes = HeaderBody c -> CertifiedVRF (VRF c) InputVRF
forall crypto. HeaderBody crypto -> CertifiedVRF crypto InputVRF
hbVrfRes HeaderBody c
headerBody,
        hvOCert :: OCert c
hvOCert = HeaderBody c -> OCert c
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert HeaderBody c
headerBody,
        hvSlotNo :: SlotNo
hvSlotNo = HeaderBody c -> SlotNo
forall crypto. HeaderBody crypto -> SlotNo
hbSlotNo HeaderBody c
headerBody,
        hvSigned :: HeaderBody c
hvSigned = HeaderBody c
headerBody,
        hvSignature :: SignedKES c (HeaderBody c)
hvSignature = SignedKES c (HeaderBody c)
headerSig
      }
  pHeaderIssuer :: ShelleyProtocolHeader (Praos c)
-> VKey 'BlockIssuer (ProtoCrypto (Praos c))
pHeaderIssuer = HeaderBody c -> VKey 'BlockIssuer c
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer crypto
hbVk (HeaderBody c -> VKey 'BlockIssuer c)
-> (Header c -> HeaderBody c) -> Header c -> VKey 'BlockIssuer c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header c -> HeaderBody c
forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody
  pHeaderIssueNo :: ShelleyProtocolHeader (Praos c) -> Word64
pHeaderIssueNo = OCert c -> Word64
forall c. OCert c -> Word64
SL.ocertN (OCert c -> Word64) -> (Header c -> OCert c) -> Header c -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderBody c -> OCert c
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert (HeaderBody c -> OCert c)
-> (Header c -> HeaderBody c) -> Header c -> OCert c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header c -> HeaderBody c
forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody

  -- This is the "unified" VRF value, prior to range extension which yields e.g.
  -- the leader VRF value used for slot election.
  --
  -- In the future, we might want to use a dedicated range-extended VRF value
  -- here instead.
  pTieBreakVRFValue :: ShelleyProtocolHeader (Praos c)
-> OutputVRF (VRF (ProtoCrypto (Praos c)))
pTieBreakVRFValue = CertifiedVRF (VRF c) InputVRF -> OutputVRF (VRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
certifiedOutput (CertifiedVRF (VRF c) InputVRF -> OutputVRF (VRF c))
-> (Header c -> CertifiedVRF (VRF c) InputVRF)
-> Header c
-> OutputVRF (VRF c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderBody c -> CertifiedVRF (VRF c) InputVRF
forall crypto. HeaderBody crypto -> CertifiedVRF crypto InputVRF
hbVrfRes (HeaderBody c -> CertifiedVRF (VRF c) InputVRF)
-> (Header c -> HeaderBody c)
-> Header c
-> CertifiedVRF (VRF c) InputVRF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header c -> HeaderBody c
forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody

instance PraosCrypto c => ProtocolHeaderSupportsLedger (Praos c) where
  mkHeaderView :: ShelleyProtocolHeader (Praos c)
-> BHeaderView (ProtoCrypto (Praos c))
mkHeaderView hdr :: ShelleyProtocolHeader (Praos c)
hdr@Header {HeaderBody c
headerBody :: forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody :: HeaderBody c
headerBody} =
    BHeaderView
      { bhviewID :: KeyHash 'BlockIssuer c
bhviewID = VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey (VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c)
-> VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall a b. (a -> b) -> a -> b
$ HeaderBody c -> VKey 'BlockIssuer c
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer crypto
hbVk HeaderBody c
headerBody,
        bhviewBSize :: Word32
bhviewBSize = HeaderBody c -> Word32
forall crypto. HeaderBody crypto -> Word32
hbBodySize HeaderBody c
headerBody,
        bhviewHSize :: Int
bhviewHSize = Header c -> Int
forall crypto. Header crypto -> Int
headerSize Header c
ShelleyProtocolHeader (Praos c)
hdr,
        bhviewBHash :: Hash c EraIndependentBlockBody
bhviewBHash = HeaderBody c -> Hash c EraIndependentBlockBody
forall crypto.
HeaderBody crypto -> Hash crypto EraIndependentBlockBody
hbBodyHash HeaderBody c
headerBody,
        bhviewSlot :: SlotNo
bhviewSlot = HeaderBody c -> SlotNo
forall crypto. HeaderBody crypto -> SlotNo
hbSlotNo HeaderBody c
headerBody
      }

type instance Signed (Header c) = HeaderBody c
instance PraosCrypto c => SignedHeader (Header c) where
  headerSigned :: Header c -> Signed (Header c)
headerSigned = Header c -> Signed (Header c)
Header c -> HeaderBody c
forall crypto. Crypto crypto => Header crypto -> HeaderBody crypto
headerBody

instance PraosCrypto c => ShelleyProtocol (Praos c)