{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.TPraos () where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Cardano.Crypto.VRF (certifiedOutput)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Protocol.Signed
import qualified Shelley.Spec.Ledger.API as SL
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config
import Ouroboros.Consensus.Shelley.Protocol
type instance BlockProtocol (ShelleyBlock era) = TPraos (EraCrypto era)
instance ShelleyBasedEra era => BlockSupportsProtocol (ShelleyBlock era) where
validateView :: BlockConfig (ShelleyBlock era)
-> Header (ShelleyBlock era)
-> ValidateView (BlockProtocol (ShelleyBlock era))
validateView BlockConfig (ShelleyBlock era)
_cfg (ShelleyHeader hdr _) = ValidateView (BlockProtocol (ShelleyBlock era))
BHeader (EraCrypto era)
hdr
selectView :: BlockConfig (ShelleyBlock era)
-> Header (ShelleyBlock era)
-> SelectView (BlockProtocol (ShelleyBlock era))
selectView BlockConfig (ShelleyBlock era)
cfg hdr :: Header (ShelleyBlock era)
hdr@(ShelleyHeader shdr _) = TPraosChainSelectView :: forall c.
BlockNo
-> SlotNo
-> SelfIssued
-> VKey 'BlockIssuer c
-> Word64
-> OutputVRF (VRF c)
-> TPraosChainSelectView c
TPraosChainSelectView {
csvChainLength :: BlockNo
csvChainLength = Header (ShelleyBlock era) -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header (ShelleyBlock era)
hdr
, csvSlotNo :: SlotNo
csvSlotNo = Header (ShelleyBlock era) -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header (ShelleyBlock era)
hdr
, csvSelfIssued :: SelfIssued
csvSelfIssued = SelfIssued
selfIssued
, csvIssuer :: VKey 'BlockIssuer (EraCrypto era)
csvIssuer = BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody
, csvIssueNo :: Word64
csvIssueNo = OCert (EraCrypto era) -> Word64
forall crypto. OCert crypto -> Word64
SL.ocertN (OCert (EraCrypto era) -> Word64)
-> (BHBody (EraCrypto era) -> OCert (EraCrypto era))
-> BHBody (EraCrypto era)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody (EraCrypto era) -> OCert (EraCrypto era)
forall crypto. BHBody crypto -> OCert crypto
SL.bheaderOCert (BHBody (EraCrypto era) -> Word64)
-> BHBody (EraCrypto era) -> Word64
forall a b. (a -> b) -> a -> b
$ BHBody (EraCrypto era)
hdrBody
, csvLeaderVRF :: OutputVRF (VRF (EraCrypto era))
csvLeaderVRF = CertifiedVRF (VRF (EraCrypto era)) Natural
-> OutputVRF (VRF (EraCrypto era))
forall v a. CertifiedVRF v a -> OutputVRF v
certifiedOutput (CertifiedVRF (VRF (EraCrypto era)) Natural
-> OutputVRF (VRF (EraCrypto era)))
-> (BHBody (EraCrypto era)
-> CertifiedVRF (VRF (EraCrypto era)) Natural)
-> BHBody (EraCrypto era)
-> OutputVRF (VRF (EraCrypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHBody (EraCrypto era)
-> CertifiedVRF (VRF (EraCrypto era)) Natural
forall crypto. BHBody crypto -> CertifiedVRF crypto Natural
SL.bheaderL (BHBody (EraCrypto era) -> OutputVRF (VRF (EraCrypto era)))
-> BHBody (EraCrypto era) -> OutputVRF (VRF (EraCrypto era))
forall a b. (a -> b) -> a -> b
$ BHBody (EraCrypto era)
hdrBody
}
where
hdrBody :: SL.BHBody (EraCrypto era)
hdrBody :: BHBody (EraCrypto era)
hdrBody = BHeader (EraCrypto era) -> BHBody (EraCrypto era)
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody BHeader (EraCrypto era)
shdr
issuerVKeys :: Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
(SL.VKey 'SL.BlockIssuer (EraCrypto era))
issuerVKeys :: Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
issuerVKeys = BlockConfig (ShelleyBlock era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
forall era.
BlockConfig (ShelleyBlock era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock era)
cfg
selfIssued :: SelfIssued
selfIssued :: SelfIssued
selfIssued = case Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
-> Int
forall k a. Map k a -> Int
Map.size Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
issuerVKeys of
Int
0 -> SelfIssued
NotSelfIssued
Int
1 | BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody VKey 'BlockIssuer (EraCrypto era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
-> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
issuerVKeys
-> SelfIssued
SelfIssued
| Bool
otherwise
-> SelfIssued
NotSelfIssued
Int
_ | VKey 'BlockIssuer (EraCrypto era)
-> KeyHash 'BlockIssuer (EraCrypto era)
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
SL.hashKey (BHBody (EraCrypto era) -> VKey 'BlockIssuer (EraCrypto era)
forall crypto. BHBody crypto -> VKey 'BlockIssuer crypto
SL.bheaderVk BHBody (EraCrypto era)
hdrBody)
KeyHash 'BlockIssuer (EraCrypto era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` BlockConfig (ShelleyBlock era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
forall era.
BlockConfig (ShelleyBlock era)
-> Map
(KeyHash 'BlockIssuer (EraCrypto era))
(VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock era)
cfg
-> SelfIssued
SelfIssued
| Bool
otherwise
-> SelfIssued
NotSelfIssued
type instance Signed (Header (ShelleyBlock era)) = SL.BHBody (EraCrypto era)
instance ShelleyBasedEra era => SignedHeader (Header (ShelleyBlock era)) where
headerSigned :: Header (ShelleyBlock era) -> Signed (Header (ShelleyBlock era))
headerSigned = BHeader (Crypto era) -> BHBody (Crypto era)
forall crypto. Crypto crypto => BHeader crypto -> BHBody crypto
SL.bhbody (BHeader (Crypto era) -> BHBody (Crypto era))
-> (Header (ShelleyBlock era) -> BHeader (Crypto era))
-> Header (ShelleyBlock era)
-> BHBody (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (ShelleyBlock era) -> BHeader (Crypto era)
forall era. Header (ShelleyBlock era) -> BHeader (EraCrypto era)
shelleyHeaderRaw