{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.VRF (certifiedOutput)
import Cardano.Ledger.BHeaderView
import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), Version)
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
  = -- | 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>.
    ObsoleteNode Version Version
  | 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)