{-# 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
pHeaderHash ShelleyProtocolHeader (Praos c)
hdr = Hash HASH EraIndependentBlockHeader -> ShelleyHash
ShelleyHash (Hash HASH EraIndependentBlockHeader -> ShelleyHash)
-> Hash HASH EraIndependentBlockHeader -> ShelleyHash
forall a b. (a -> b) -> a -> b
$ Header c -> Hash HASH EraIndependentBlockHeader
forall crypto.
Crypto crypto =>
Header crypto -> Hash HASH EraIndependentBlockHeader
headerHash Header c
ShelleyProtocolHeader (Praos c)
hdr
  pHeaderPrevHash :: ShelleyProtocolHeader (Praos c) -> PrevHash
pHeaderPrevHash (Header HeaderBody c
body SignedKES (KES c) (HeaderBody c)
_) = HeaderBody c -> PrevHash
forall crypto. HeaderBody crypto -> PrevHash
hbPrev HeaderBody c
body
  pHeaderBodyHash :: ShelleyProtocolHeader (Praos c)
-> Hash HASH EraIndependentBlockBody
pHeaderBodyHash (Header HeaderBody c
body SignedKES (KES c) (HeaderBody c)
_) = HeaderBody c -> Hash HASH EraIndependentBlockBody
forall crypto.
HeaderBody crypto -> Hash HASH EraIndependentBlockBody
hbBodyHash HeaderBody c
body
  pHeaderSlot :: ShelleyProtocolHeader (Praos c) -> SlotNo
pHeaderSlot (Header HeaderBody c
body SignedKES (KES 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 (KES 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 (KES 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 -> Int
bhviewHSize BHeaderView
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 -> Int
bhviewHSize BHeaderView
bhv) Word16
maxHeaderSize
    Bool
-> ExceptT PraosEnvelopeError Identity ()
-> ExceptT PraosEnvelopeError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Word32
bhviewBSize BHeaderView
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 -> Word32
bhviewBSize BHeaderView
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 -> ProtVer
lvProtocolVersion LedgerView (Praos c)
LedgerView
lv
      maxHeaderSize :: Word16
maxHeaderSize = LedgerView -> Word16
lvMaxHeaderSize LedgerView (Praos c)
LedgerView
lv
      maxBodySize :: Word32
maxBodySize = LedgerView -> Word32
lvMaxBodySize LedgerView (Praos c)
LedgerView
lv
      bhv :: BHeaderView
bhv = ShelleyProtocolHeader (Praos c) -> BHeaderView
forall proto.
ProtocolHeaderSupportsLedger proto =>
ShelleyProtocolHeader proto -> BHeaderView
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 (KES crypto) (HeaderBody crypto)
headerSig} = ShelleyProtocolHeader (Praos c)
header
      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
        } = 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
-> Hash HASH 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
prevHash Hash HASH EraIndependentBlockBody
bbHash Int
sz ProtVer
protVer = do
    PraosFields {praosSignature, 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, Signable (KES 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
    pure $ Header praosToSign praosSignature
    where
      mkBhBodyBytes :: PraosToSign crypto -> HeaderBody crypto
mkBhBodyBytes
        PraosToSign
          { VKey 'BlockIssuer
praosToSignIssuerVK :: VKey 'BlockIssuer
praosToSignIssuerVK :: forall c. PraosToSign c -> VKey 'BlockIssuer
praosToSignIssuerVK,
            VerKeyVRF (VRF crypto)
praosToSignVrfVK :: VerKeyVRF (VRF crypto)
praosToSignVrfVK :: forall c. PraosToSign c -> VerKeyVRF (VRF c)
praosToSignVrfVK,
            CertifiedVRF (VRF crypto) InputVRF
praosToSignVrfRes :: CertifiedVRF (VRF crypto) InputVRF
praosToSignVrfRes :: forall c. PraosToSign c -> CertifiedVRF (VRF 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
hbPrev = PrevHash
prevHash,
              hbVk :: VKey 'BlockIssuer
hbVk = VKey 'BlockIssuer
praosToSignIssuerVK,
              hbVrfVk :: VerKeyVRF (VRF crypto)
hbVrfVk = VerKeyVRF (VRF crypto)
praosToSignVrfVK,
              hbVrfRes :: CertifiedVRF (VRF crypto) InputVRF
hbVrfRes = CertifiedVRF (VRF crypto) InputVRF
praosToSignVrfRes,
              hbBodySize :: Word32
hbBodySize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz,
              hbBodyHash :: Hash HASH EraIndependentBlockBody
hbBodyHash = Hash HASH 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 (KES c) (HeaderBody c)
headerSig :: forall crypto.
Crypto crypto =>
Header crypto -> SignedKES (KES crypto) (HeaderBody crypto)
headerSig :: SignedKES (KES c) (HeaderBody c)
headerSig} =
    HeaderView
      { hvPrevHash :: PrevHash
hvPrevHash = HeaderBody c -> PrevHash
forall crypto. HeaderBody crypto -> PrevHash
hbPrev HeaderBody c
headerBody,
        hvVK :: VKey 'BlockIssuer
hvVK = HeaderBody c -> VKey 'BlockIssuer
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer
hbVk HeaderBody c
headerBody,
        hvVrfVK :: VerKeyVRF (VRF c)
hvVrfVK = HeaderBody c -> VerKeyVRF (VRF c)
forall crypto. HeaderBody crypto -> VerKeyVRF (VRF crypto)
hbVrfVk HeaderBody c
headerBody,
        hvVrfRes :: CertifiedVRF (VRF c) InputVRF
hvVrfRes = HeaderBody c -> CertifiedVRF (VRF c) InputVRF
forall crypto.
HeaderBody crypto -> CertifiedVRF (VRF 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 (KES c) (HeaderBody c)
hvSignature = SignedKES (KES c) (HeaderBody c)
headerSig
      }
  pHeaderIssuer :: ShelleyProtocolHeader (Praos c) -> VKey 'BlockIssuer
pHeaderIssuer = HeaderBody c -> VKey 'BlockIssuer
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer
hbVk (HeaderBody c -> VKey 'BlockIssuer)
-> (Header c -> HeaderBody c) -> Header c -> VKey 'BlockIssuer
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 (VRF 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
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
bhviewID = VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey 'BlockIssuer -> KeyHash 'BlockIssuer)
-> VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ HeaderBody c -> VKey 'BlockIssuer
forall crypto. HeaderBody crypto -> VKey 'BlockIssuer
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 HASH EraIndependentBlockBody
bhviewBHash = HeaderBody c -> Hash HASH EraIndependentBlockBody
forall crypto.
HeaderBody crypto -> Hash HASH 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)