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

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

import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.VRF (certifiedOutput)
import Cardano.Ledger.BaseTypes (ProtVer (ProtVer))
import Cardano.Ledger.Chain (ChainChecksPParams (..))
import Cardano.Ledger.Slot (SlotNo (unSlotNo))
import Cardano.Protocol.Praos.BlockHeader
  ( Header (..)
  , HeaderBody (..)
  , headerHash
  , headerSize
  )
import Cardano.Protocol.TPraos.OCert
  ( OCert (ocertKESPeriod, ocertVkHot)
  )
import qualified Cardano.Protocol.TPraos.OCert as SL
import Data.Either (isRight)
import Ouroboros.Consensus.Protocol.Praos
import Ouroboros.Consensus.Protocol.Praos.Common
  ( MaxMajorProtVer (MaxMajorProtVer)
  )
import Ouroboros.Consensus.Protocol.Praos.Views
import Ouroboros.Consensus.Protocol.Signed
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ProtoCrypto
  , ProtocolHeaderSupportsEnvelope (..)
  , ProtocolHeaderSupportsKES (..)
  , ProtocolHeaderSupportsProtocol (..)
  , ShelleyHash (ShelleyHash)
  , ShelleyProtocol
  , ShelleyProtocolHeader
  )
import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks
  ( EnvelopeError
  , EnvelopeHeaderView (..)
  , envelopeCheck
  )

type instance ProtoCrypto (Praos c) = c

type instance ShelleyProtocolHeader (Praos c) = Header c

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. 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 _ = EnvelopeError

  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 =
    Version
-> ChainChecksPParams
-> EnvelopeHeaderView
-> Except EnvelopeError ()
envelopeCheck Version
maxpv ChainChecksPParams
ccd (EnvelopeHeaderView -> Except EnvelopeError ())
-> EnvelopeHeaderView -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
      EnvelopeHeaderView
        { ehvProtVer :: Version
ehvProtVer = Version
m
        , ehvHeaderSize :: Int
ehvHeaderSize = Header c -> Int
forall crypto. Header crypto -> Int
headerSize Header c
ShelleyProtocolHeader (Praos c)
hdr
        , ehvBodySize :: Word32
ehvBodySize = HeaderBody c -> Word32
forall crypto. HeaderBody crypto -> Word32
hbBodySize HeaderBody c
body
        }
   where
    Header HeaderBody c
body SignedKES (KES c) (HeaderBody c)
_ = ShelleyProtocolHeader (Praos c)
hdr
    MaxMajorProtVer Version
maxpv = PraosParams -> MaxMajorProtVer
praosMaxMajorPV (ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams ConsensusConfig (Praos c)
cfg)
    ProtVer Version
m Word32
_ = PraosLedgerView -> ProtVer
plvProtocolVersion LedgerView (Praos c)
PraosLedgerView
lv
    ccd :: ChainChecksPParams
ccd =
      ChainChecksPParams
        { ccMaxBHSize :: Word16
ccMaxBHSize = PraosLedgerView -> Word16
plvMaxHeaderSize LedgerView (Praos c)
PraosLedgerView
lv
        , ccMaxBBSize :: Word32
ccMaxBBSize = PraosLedgerView -> Word32
plvMaxBodySize LedgerView (Praos c)
PraosLedgerView
lv
        , ccProtocolVersion :: ProtVer
ccProtocolVersion = PraosLedgerView -> ProtVer
plvProtocolVersion LedgerView (Praos c)
PraosLedgerView
lv
        }

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

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

instance PraosCrypto c => ShelleyProtocol (Praos c)