{-# 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 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           Ouroboros.Consensus.Protocol.Signed (Signed,
                     SignedHeader (headerSigned))
import           Ouroboros.Consensus.Protocol.TPraos
                     (MaxMajorProtVer (MaxMajorProtVer), TPraos,
                     TPraosCannotForge, TPraosFields (..), TPraosToSign (..),
                     Ticked (TickedPraosLedgerView), 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 ShelleyProtocolHeader (TPraos c) = SL.BHeader c

instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where
  pHeaderHash :: ShelleyProtocolHeader (TPraos c)
-> ShelleyHash (ProtoCrypto (TPraos c))
pHeaderHash = Hash (HASH c) EraIndependentBlockHeader -> ShelleyHash c
forall crypto.
Hash crypto EraIndependentBlockHeader -> ShelleyHash crypto
ShelleyHash (Hash (HASH c) EraIndependentBlockHeader -> ShelleyHash c)
-> (BHeader c -> Hash (HASH c) EraIndependentBlockHeader)
-> BHeader c
-> ShelleyHash c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashHeader c -> Hash (HASH c) EraIndependentBlockHeader
forall crypto.
HashHeader crypto -> Hash crypto EraIndependentBlockHeader
SL.unHashHeader (HashHeader c -> Hash (HASH c) EraIndependentBlockHeader)
-> (BHeader c -> HashHeader c)
-> BHeader c
-> Hash (HASH c) EraIndependentBlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> HashHeader c
forall crypto. Crypto crypto => BHeader crypto -> HashHeader crypto
SL.bhHash
  pHeaderPrevHash :: ShelleyProtocolHeader (TPraos c)
-> PrevHash (ProtoCrypto (TPraos c))
pHeaderPrevHash = BHBody c -> PrevHash c
forall crypto. BHBody crypto -> PrevHash crypto
SL.bheaderPrev (BHBody c -> PrevHash c)
-> (BHeader c -> BHBody c) -> BHeader c -> PrevHash c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody
  pHeaderBodyHash :: ShelleyProtocolHeader (TPraos c)
-> Hash (ProtoCrypto (TPraos c)) EraIndependentBlockBody
pHeaderBodyHash = BHBody c -> Hash (HASH c) EraIndependentBlockBody
forall crypto. BHBody crypto -> Hash crypto EraIndependentBlockBody
SL.bhash (BHBody c -> Hash (HASH c) EraIndependentBlockBody)
-> (BHeader c -> BHBody c)
-> BHeader c
-> Hash (HASH c) EraIndependentBlockBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody
  pHeaderSlot :: ShelleyProtocolHeader (TPraos c) -> SlotNo
pHeaderSlot = BHBody c -> SlotNo
forall crypto. BHBody crypto -> 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 crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody
  pHeaderBlock :: ShelleyProtocolHeader (TPraos c) -> BlockNo
pHeaderBlock = BHBody c -> BlockNo
forall crypto. BHBody crypto -> 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 crypto. Crypto crypto => BHeader crypto -> BHBody crypto
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 crypto. BHeader crypto -> Int
SL.bHeaderSize
  pHeaderBlockSize :: ShelleyProtocolHeader (TPraos c) -> Natural
pHeaderBlockSize = BHBody c -> Natural
forall crypto. BHBody crypto -> Natural
SL.bsize (BHBody c -> Natural)
-> (BHeader c -> BHBody c) -> BHeader c -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody

  type EnvelopeCheckError _ = ChainPredicateFailure

  envelopeChecks :: ConsensusConfig (TPraos c)
-> Ticked (LedgerView (TPraos c))
-> ShelleyProtocolHeader (TPraos c)
-> Except (EnvelopeCheckError (TPraos c)) ()
envelopeChecks ConsensusConfig (TPraos c)
cfg (TickedPraosLedgerView lv) ShelleyProtocolHeader (TPraos c)
hdr =
    Natural
-> ChainChecksPParams
-> BHeaderView c
-> ExceptT ChainPredicateFailure Identity ()
forall crypto (m :: * -> *).
MonadError ChainPredicateFailure m =>
Natural -> ChainChecksPParams -> BHeaderView crypto -> m ()
SL.chainChecks
      Natural
maxPV
      (LedgerView c -> ChainChecksPParams
forall crypto. LedgerView crypto -> ChainChecksPParams
SL.lvChainChecks LedgerView c
lv)
      (BHeader c -> BHeaderView c
forall crypto.
Crypto crypto =>
BHeader crypto -> BHeaderView crypto
SL.makeHeaderView (BHeader c -> BHeaderView c) -> BHeader c -> BHeaderView c
forall a b. (a -> b) -> a -> b
$ ShelleyProtocolHeader (TPraos c) -> ValidateView (TPraos c)
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> ValidateView proto
protocolHeaderView @(TPraos c) ShelleyProtocolHeader (TPraos c)
hdr)
    where
      MaxMajorProtVer Natural
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)
-> Period
-> BHBody c
-> SignedKES (KES c) (BHBody c)
-> Either String ()
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v
-> VerKeyKES v -> Period -> a -> SignedKES v a -> Either String ()
SL.verifySignedKES () VerKeyKES (KES c)
ocertVkHot Period
t BHBody c
hdrBody SignedKES (KES c) (BHBody c)
hdrSignature
    where
      SL.BHeader BHBody c
hdrBody SignedKES (KES c) (BHBody c)
hdrSignature = BHeader c
ShelleyProtocolHeader (TPraos c)
hdr
      SL.OCert
        { VerKeyKES (KES c)
ocertVkHot :: VerKeyKES (KES c)
ocertVkHot :: forall crypto. OCert crypto -> VerKeyKES crypto
ocertVkHot,
          ocertKESPeriod :: forall crypto. OCert crypto -> KESPeriod
ocertKESPeriod = SL.KESPeriod Period
startOfKesPeriod
        } = BHBody c -> OCert c
forall crypto. BHBody crypto -> OCert crypto
SL.bheaderOCert BHBody c
hdrBody

      currentKesPeriod :: Period
currentKesPeriod =
        Word64 -> Period
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Period) -> Word64 -> Period
forall a b. (a -> b) -> a -> b
$
          SlotNo -> Word64
unSlotNo (BHBody c -> SlotNo
forall crypto. BHBody crypto -> SlotNo
SL.bheaderSlotNo (BHBody c -> SlotNo) -> BHBody c -> SlotNo
forall a b. (a -> b) -> a -> b
$ BHeader c -> BHBody c
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody BHeader c
ShelleyProtocolHeader (TPraos c)
hdr) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
slotsPerKESPeriod

      t :: Period
t
        | Period
currentKesPeriod Period -> Period -> Bool
forall a. Ord a => a -> a -> Bool
>= Period
startOfKesPeriod =
          Period
currentKesPeriod Period -> Period -> Period
forall a. Num a => a -> a -> a
- Period
startOfKesPeriod
        | Bool
otherwise =
          Period
0
  mkHeader :: HotKey crypto m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> SlotNo
-> BlockNo
-> PrevHash crypto
-> Hash crypto 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 crypto
prevHash Hash crypto EraIndependentBlockBody
bbHash Int
actualBodySize ProtVer
protVer = do
    TPraosFields {SignedKES crypto (BHBody crypto)
tpraosSignature :: forall c toSign. TPraosFields c toSign -> SignedKES c toSign
tpraosSignature :: SignedKES crypto (BHBody crypto)
tpraosSignature, BHBody crypto
tpraosToSign :: forall c toSign. TPraosFields c toSign -> toSign
tpraosToSign :: BHBody crypto
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, KESignable 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
    BHeader crypto -> m (BHeader crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BHeader crypto -> m (BHeader crypto))
-> BHeader crypto -> m (BHeader crypto)
forall a b. (a -> b) -> a -> b
$ BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
forall crypto.
Crypto crypto =>
BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
SL.BHeader BHBody crypto
tpraosToSign SignedKES crypto (BHBody crypto)
tpraosSignature
    where
      mkBhBody :: TPraosToSign crypto -> BHBody crypto
mkBhBody TPraosToSign crypto
toSign =
        BHBody :: forall crypto.
BlockNo
-> SlotNo
-> PrevHash crypto
-> VKey 'BlockIssuer crypto
-> VerKeyVRF crypto
-> CertifiedVRF crypto Nonce
-> CertifiedVRF crypto Natural
-> Natural
-> Hash crypto EraIndependentBlockBody
-> OCert crypto
-> ProtVer
-> BHBody crypto
SL.BHBody
          { bheaderPrev :: PrevHash crypto
SL.bheaderPrev = PrevHash crypto
prevHash,
            bheaderVk :: VKey 'BlockIssuer crypto
SL.bheaderVk = VKey 'BlockIssuer crypto
tpraosToSignIssuerVK,
            bheaderVrfVk :: VerKeyVRF crypto
SL.bheaderVrfVk = VerKeyVRF crypto
tpraosToSignVrfVK,
            bheaderSlotNo :: SlotNo
SL.bheaderSlotNo = SlotNo
curSlot,
            bheaderBlockNo :: BlockNo
SL.bheaderBlockNo = BlockNo
curNo,
            bheaderEta :: CertifiedVRF crypto Nonce
SL.bheaderEta = CertifiedVRF crypto Nonce
tpraosToSignEta,
            bheaderL :: CertifiedVRF crypto Natural
SL.bheaderL = CertifiedVRF crypto Natural
tpraosToSignLeader,
            bsize :: Natural
SL.bsize = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
actualBodySize,
            bhash :: Hash crypto EraIndependentBlockBody
SL.bhash = Hash crypto EraIndependentBlockBody
bbHash,
            bheaderOCert :: OCert crypto
SL.bheaderOCert = OCert crypto
tpraosToSignOCert,
            bprotver :: ProtVer
SL.bprotver = ProtVer
protVer
          }
        where
          TPraosToSign
            { VKey 'BlockIssuer crypto
tpraosToSignIssuerVK :: forall c. TPraosToSign c -> VKey 'BlockIssuer c
tpraosToSignIssuerVK :: VKey 'BlockIssuer crypto
tpraosToSignIssuerVK,
              VerKeyVRF crypto
tpraosToSignVrfVK :: forall c. TPraosToSign c -> VerKeyVRF c
tpraosToSignVrfVK :: VerKeyVRF crypto
tpraosToSignVrfVK,
              CertifiedVRF crypto Nonce
tpraosToSignEta :: forall c. TPraosToSign c -> CertifiedVRF c Nonce
tpraosToSignEta :: CertifiedVRF crypto Nonce
tpraosToSignEta,
              CertifiedVRF crypto Natural
tpraosToSignLeader :: forall c. TPraosToSign c -> CertifiedVRF c Natural
tpraosToSignLeader :: CertifiedVRF crypto Natural
tpraosToSignLeader,
              OCert crypto
tpraosToSignOCert :: forall c. TPraosToSign c -> OCert c
tpraosToSignOCert :: OCert crypto
tpraosToSignOCert
            } = TPraosToSign crypto
toSign

instance PraosCrypto c => ProtocolHeaderSupportsProtocol (TPraos c) where
  type CannotForgeError _ = TPraosCannotForge c

  protocolHeaderView :: ShelleyProtocolHeader (TPraos c) -> ValidateView (TPraos c)
protocolHeaderView = ShelleyProtocolHeader (TPraos c) -> ValidateView (TPraos c)
forall a. a -> a
id
  pHeaderIssuer :: ShelleyProtocolHeader (TPraos c)
-> VKey 'BlockIssuer (ProtoCrypto (TPraos c))
pHeaderIssuer = BHBody c -> VKey 'BlockIssuer c
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk (BHBody c -> VKey 'BlockIssuer c)
-> (BHeader c -> BHBody c) -> BHeader c -> VKey 'BlockIssuer c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader c -> BHBody c
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody
  pHeaderIssueNo :: ShelleyProtocolHeader (TPraos c) -> Word64
pHeaderIssueNo = OCert c -> Word64
forall crypto. OCert crypto -> 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 crypto. BHBody crypto -> OCert crypto
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 crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody
  pHeaderVRFValue :: ShelleyProtocolHeader (TPraos c)
-> OutputVRF (VRF (ProtoCrypto (TPraos c)))
pHeaderVRFValue = 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 crypto. BHBody crypto -> CertifiedVRF crypto 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 crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody

instance PraosCrypto c => ProtocolHeaderSupportsLedger (TPraos c) where
  mkHeaderView :: ShelleyProtocolHeader (TPraos c)
-> BHeaderView (ProtoCrypto (TPraos c))
mkHeaderView = ShelleyProtocolHeader (TPraos c)
-> BHeaderView (ProtoCrypto (TPraos c))
forall crypto.
Crypto crypto =>
BHeader crypto -> BHeaderView crypto
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 -> Signed (BHeader c)
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody

instance PraosCrypto c => ShelleyProtocol (TPraos c)