{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Byron.Ledger.Forge (
forgeByronBlock
, forgeRegularBlock
, forgeEBB
) where
import Control.Monad (void)
import Data.ByteString (ByteString)
import Data.Coerce (coerce)
import GHC.Stack
import Cardano.Binary (Annotated (..), reAnnotate)
import qualified Cardano.Chain.Block as CC.Block
import qualified Cardano.Chain.Byron.API as CC
import qualified Cardano.Chain.Common as CC.Common
import qualified Cardano.Chain.Delegation as CC.Delegation
import qualified Cardano.Chain.Genesis as CC.Genesis
import qualified Cardano.Chain.Slotting as CC.Slot
import qualified Cardano.Chain.Ssc as CC.Ssc
import qualified Cardano.Chain.UTxO as CC.UTxO
import qualified Cardano.Chain.Update as CC.Update
import qualified Cardano.Crypto as Crypto
import Cardano.Crypto.DSIGN
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
(LedgerSupportsMempool (..), txForgetValidated)
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
import Ouroboros.Consensus.Protocol.PBFT
import Ouroboros.Consensus.Byron.Crypto.DSIGN
import Ouroboros.Consensus.Byron.Ledger.Block
import Ouroboros.Consensus.Byron.Ledger.Config
import Ouroboros.Consensus.Byron.Ledger.Mempool
import Ouroboros.Consensus.Byron.Ledger.PBFT
import Ouroboros.Consensus.Byron.Protocol
forgeByronBlock
:: HasCallStack
=> TopLevelConfig ByronBlock
-> TxLimits.Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeByronBlock :: TopLevelConfig ByronBlock
-> Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeByronBlock TopLevelConfig ByronBlock
cfg = HasCallStack =>
BlockConfig ByronBlock
-> Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
BlockConfig ByronBlock
-> Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeRegularBlock (TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
cfg)
forgeEBB
:: BlockConfig ByronBlock
-> SlotNo
-> BlockNo
-> ChainHash ByronBlock
-> ByronBlock
forgeEBB :: BlockConfig ByronBlock
-> SlotNo -> BlockNo -> ChainHash ByronBlock -> ByronBlock
forgeEBB BlockConfig ByronBlock
cfg SlotNo
curSlot BlockNo
curNo ChainHash ByronBlock
prevHash =
EpochSlots -> ABlockOrBoundary ByteString -> ByronBlock
mkByronBlock EpochSlots
epochSlots
(ABlockOrBoundary ByteString -> ByronBlock)
-> (ABoundaryBlock () -> ABlockOrBoundary ByteString)
-> ABoundaryBlock ()
-> ByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ABoundaryBlock ByteString -> ABlockOrBoundary ByteString
forall a. ABoundaryBlock a -> ABlockOrBoundary a
CC.Block.ABOBBoundary
(ABoundaryBlock ByteString -> ABlockOrBoundary ByteString)
-> (ABoundaryBlock () -> ABoundaryBlock ByteString)
-> ABoundaryBlock ()
-> ABlockOrBoundary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolMagicId -> ABoundaryBlock () -> ABoundaryBlock ByteString
CC.reAnnotateBoundary (BlockConfig ByronBlock -> ProtocolMagicId
byronProtocolMagicId BlockConfig ByronBlock
cfg)
(ABoundaryBlock () -> ByronBlock)
-> ABoundaryBlock () -> ByronBlock
forall a b. (a -> b) -> a -> b
$ ABoundaryBlock ()
boundaryBlock
where
epochSlots :: CC.Slot.EpochSlots
epochSlots :: EpochSlots
epochSlots = BlockConfig ByronBlock -> EpochSlots
byronEpochSlots BlockConfig ByronBlock
cfg
prevHeaderHash :: Either CC.Genesis.GenesisHash CC.Block.HeaderHash
prevHeaderHash :: Either GenesisHash HeaderHash
prevHeaderHash = case ChainHash ByronBlock
prevHash of
ChainHash ByronBlock
GenesisHash -> GenesisHash -> Either GenesisHash HeaderHash
forall a b. a -> Either a b
Left (BlockConfig ByronBlock -> GenesisHash
byronGenesisHash BlockConfig ByronBlock
cfg)
BlockHash (ByronHash h) -> HeaderHash -> Either GenesisHash HeaderHash
forall a b. b -> Either a b
Right HeaderHash
h
boundaryBlock :: CC.Block.ABoundaryBlock ()
boundaryBlock :: ABoundaryBlock ()
boundaryBlock =
ABoundaryBlock :: forall a.
Int64
-> ABoundaryHeader a -> ABoundaryBody a -> a -> ABoundaryBlock a
CC.Block.ABoundaryBlock {
boundaryBlockLength :: Int64
CC.Block.boundaryBlockLength = Int64
0
, ABoundaryHeader ()
boundaryHeader :: ABoundaryHeader ()
boundaryHeader :: ABoundaryHeader ()
CC.Block.boundaryHeader
, boundaryBody :: ABoundaryBody ()
CC.Block.boundaryBody = () -> ABoundaryBody ()
forall a. a -> ABoundaryBody a
CC.Block.ABoundaryBody ()
, boundaryAnnotation :: ()
CC.Block.boundaryAnnotation = ()
}
boundaryHeader :: CC.Block.ABoundaryHeader ()
boundaryHeader :: ABoundaryHeader ()
boundaryHeader = Either GenesisHash HeaderHash
-> Word64 -> ChainDifficulty -> () -> ABoundaryHeader ()
forall a.
Either GenesisHash HeaderHash
-> Word64 -> ChainDifficulty -> a -> ABoundaryHeader a
CC.Block.mkABoundaryHeader
Either GenesisHash HeaderHash
prevHeaderHash
Word64
epoch
(BlockNo -> ChainDifficulty
coerce BlockNo
curNo)
()
where
CC.Slot.EpochNumber Word64
epoch =
EpochSlots -> SlotNumber -> EpochNumber
CC.Slot.slotNumberEpoch EpochSlots
epochSlots (SlotNo -> SlotNumber
coerce SlotNo
curSlot)
data BlockPayloads = BlockPayloads
{ BlockPayloads -> [TxAux]
bpTxs :: ![CC.UTxO.TxAux]
, BlockPayloads -> [Certificate]
bpDlgCerts :: ![CC.Delegation.Certificate]
, BlockPayloads -> [Vote]
bpUpVotes :: ![CC.Update.Vote]
, BlockPayloads -> Maybe Proposal
bpUpProposal :: !(Maybe CC.Update.Proposal)
}
initBlockPayloads :: BlockPayloads
initBlockPayloads :: BlockPayloads
initBlockPayloads = BlockPayloads :: [TxAux]
-> [Certificate] -> [Vote] -> Maybe Proposal -> BlockPayloads
BlockPayloads
{ bpTxs :: [TxAux]
bpTxs = []
, bpDlgCerts :: [Certificate]
bpDlgCerts = []
, bpUpVotes :: [Vote]
bpUpVotes = []
, bpUpProposal :: Maybe Proposal
bpUpProposal = Maybe Proposal
forall a. Maybe a
Nothing
}
forgeRegularBlock
:: HasCallStack
=> BlockConfig ByronBlock
-> TxLimits.Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeRegularBlock :: BlockConfig ByronBlock
-> Overrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeRegularBlock BlockConfig ByronBlock
cfg Overrides ByronBlock
maxTxCapacityOverrides BlockNo
bno SlotNo
sno TickedLedgerState ByronBlock
st [Validated (GenTx ByronBlock)]
txs PBftIsLeader PBftByronCrypto
isLeader =
PBftFields PBftByronCrypto (Annotated ToSign ByteString)
-> ByronBlock
forge (PBftFields PBftByronCrypto (Annotated ToSign ByteString)
-> ByronBlock)
-> PBftFields PBftByronCrypto (Annotated ToSign ByteString)
-> ByronBlock
forall a b. (a -> b) -> a -> b
$
(VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> ContextDSIGN (PBftDSIGN PBftByronCrypto))
-> IsLeader (PBft PBftByronCrypto)
-> Annotated ToSign ByteString
-> PBftFields PBftByronCrypto (Annotated ToSign ByteString)
forall c toSign.
(PBftCrypto c, Signable (PBftDSIGN c) toSign) =>
(VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c))
-> IsLeader (PBft c) -> toSign -> PBftFields c toSign
forgePBftFields
(BlockConfig ByronBlock
-> VerKeyDSIGN ByronDSIGN -> ContextDSIGN ByronDSIGN
mkByronContextDSIGN BlockConfig ByronBlock
cfg)
PBftIsLeader PBftByronCrypto
IsLeader (PBft PBftByronCrypto)
isLeader
(Annotated ToSign () -> Annotated ToSign ByteString
forall a b. ToCBOR a => Annotated a b -> Annotated a ByteString
reAnnotate (Annotated ToSign () -> Annotated ToSign ByteString)
-> Annotated ToSign () -> Annotated ToSign ByteString
forall a b. (a -> b) -> a -> b
$ ToSign -> () -> Annotated ToSign ()
forall b a. b -> a -> Annotated b a
Annotated ToSign
toSign ())
where
epochSlots :: CC.Slot.EpochSlots
epochSlots :: EpochSlots
epochSlots = BlockConfig ByronBlock -> EpochSlots
byronEpochSlots BlockConfig ByronBlock
cfg
blockPayloads :: BlockPayloads
blockPayloads :: BlockPayloads
blockPayloads =
(Validated (GenTx ByronBlock) -> BlockPayloads -> BlockPayloads)
-> BlockPayloads -> [Validated (GenTx ByronBlock)] -> BlockPayloads
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
Validated (GenTx ByronBlock) -> BlockPayloads -> BlockPayloads
extendBlockPayloads
BlockPayloads
initBlockPayloads
(Overrides ByronBlock
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> [Validated (GenTx ByronBlock)]
forall blk.
TxLimits blk =>
Overrides blk
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> [Validated (GenTx blk)]
takeLargestPrefixThatFits Overrides ByronBlock
maxTxCapacityOverrides TickedLedgerState ByronBlock
st [Validated (GenTx ByronBlock)]
txs)
txPayload :: CC.UTxO.TxPayload
txPayload :: TxPayload
txPayload = [TxAux] -> TxPayload
CC.UTxO.mkTxPayload (BlockPayloads -> [TxAux]
bpTxs BlockPayloads
blockPayloads)
dlgPayload :: CC.Delegation.Payload
dlgPayload :: Payload
dlgPayload = [Certificate] -> Payload
CC.Delegation.unsafePayload (BlockPayloads -> [Certificate]
bpDlgCerts BlockPayloads
blockPayloads)
updatePayload :: CC.Update.Payload
updatePayload :: Payload
updatePayload = Maybe Proposal -> [Vote] -> Payload
CC.Update.payload (BlockPayloads -> Maybe Proposal
bpUpProposal BlockPayloads
blockPayloads)
(BlockPayloads -> [Vote]
bpUpVotes BlockPayloads
blockPayloads)
extendBlockPayloads :: Validated (GenTx ByronBlock)
-> BlockPayloads
-> BlockPayloads
extendBlockPayloads :: Validated (GenTx ByronBlock) -> BlockPayloads -> BlockPayloads
extendBlockPayloads Validated (GenTx ByronBlock)
validatedGenTx bp :: BlockPayloads
bp@BlockPayloads{[TxAux]
bpTxs :: [TxAux]
bpTxs :: BlockPayloads -> [TxAux]
bpTxs, [Certificate]
bpDlgCerts :: [Certificate]
bpDlgCerts :: BlockPayloads -> [Certificate]
bpDlgCerts, [Vote]
bpUpVotes :: [Vote]
bpUpVotes :: BlockPayloads -> [Vote]
bpUpVotes} =
case Validated (GenTx ByronBlock) -> GenTx ByronBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx ByronBlock)
validatedGenTx of
ByronTx _ tx -> BlockPayloads
bp { bpTxs :: [TxAux]
bpTxs = ATxAux ByteString -> TxAux
forall (f :: * -> *) a. Functor f => f a -> f ()
void ATxAux ByteString
tx TxAux -> [TxAux] -> [TxAux]
forall a. a -> [a] -> [a]
: [TxAux]
bpTxs }
ByronDlg _ cert -> BlockPayloads
bp { bpDlgCerts :: [Certificate]
bpDlgCerts = ACertificate ByteString -> Certificate
forall (f :: * -> *) a. Functor f => f a -> f ()
void ACertificate ByteString
cert Certificate -> [Certificate] -> [Certificate]
forall a. a -> [a] -> [a]
: [Certificate]
bpDlgCerts }
ByronUpdateProposal _ prop -> BlockPayloads
bp { bpUpProposal :: Maybe Proposal
bpUpProposal = Proposal -> Maybe Proposal
forall a. a -> Maybe a
Just (AProposal ByteString -> Proposal
forall (f :: * -> *) a. Functor f => f a -> f ()
void AProposal ByteString
prop) }
ByronUpdateVote _ vote -> BlockPayloads
bp { bpUpVotes :: [Vote]
bpUpVotes = AVote ByteString -> Vote
forall (f :: * -> *) a. Functor f => f a -> f ()
void AVote ByteString
vote Vote -> [Vote] -> [Vote]
forall a. a -> [a] -> [a]
: [Vote]
bpUpVotes }
body :: CC.Block.Body
body :: Body
body = ABody :: forall a.
ATxPayload a -> SscPayload -> APayload a -> APayload a -> ABody a
CC.Block.ABody {
bodyTxPayload :: TxPayload
CC.Block.bodyTxPayload = TxPayload
txPayload
, bodySscPayload :: SscPayload
CC.Block.bodySscPayload = SscPayload
CC.Ssc.SscPayload
, bodyDlgPayload :: Payload
CC.Block.bodyDlgPayload = Payload
dlgPayload
, bodyUpdatePayload :: Payload
CC.Block.bodyUpdatePayload = Payload
updatePayload
}
proof :: CC.Block.Proof
proof :: Proof
proof = Body -> Proof
CC.Block.mkProof Body
body
prevHeaderHash :: CC.Block.HeaderHash
prevHeaderHash :: HeaderHash
prevHeaderHash = case TickedLedgerState ByronBlock
-> ChainHash (TickedLedgerState ByronBlock)
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState ByronBlock
st of
ChainHash (TickedLedgerState ByronBlock)
GenesisHash -> [Char] -> HeaderHash
forall a. HasCallStack => [Char] -> a
error
[Char]
"the first block on the Byron chain must be an EBB"
BlockHash (ByronHash h) -> HeaderHash
h
epochAndSlotCount :: CC.Slot.EpochAndSlotCount
epochAndSlotCount :: EpochAndSlotCount
epochAndSlotCount = EpochSlots -> SlotNumber -> EpochAndSlotCount
CC.Slot.fromSlotNumber EpochSlots
epochSlots (SlotNo -> SlotNumber
coerce SlotNo
sno)
toSign :: CC.Block.ToSign
toSign :: ToSign
toSign = ToSign :: HeaderHash
-> Proof
-> EpochAndSlotCount
-> ChainDifficulty
-> ProtocolVersion
-> SoftwareVersion
-> ToSign
CC.Block.ToSign {
tsHeaderHash :: HeaderHash
CC.Block.tsHeaderHash = HeaderHash
prevHeaderHash
, tsSlot :: EpochAndSlotCount
CC.Block.tsSlot = EpochAndSlotCount
epochAndSlotCount
, tsDifficulty :: ChainDifficulty
CC.Block.tsDifficulty = BlockNo -> ChainDifficulty
coerce BlockNo
bno
, tsBodyProof :: Proof
CC.Block.tsBodyProof = Proof
proof
, tsProtocolVersion :: ProtocolVersion
CC.Block.tsProtocolVersion = BlockConfig ByronBlock -> ProtocolVersion
byronProtocolVersion BlockConfig ByronBlock
cfg
, tsSoftwareVersion :: SoftwareVersion
CC.Block.tsSoftwareVersion = BlockConfig ByronBlock -> SoftwareVersion
byronSoftwareVersion BlockConfig ByronBlock
cfg
}
dlgCertificate :: CC.Delegation.Certificate
dlgCertificate :: Certificate
dlgCertificate = PBftIsLeader PBftByronCrypto -> PBftDelegationCert PBftByronCrypto
forall c. PBftIsLeader c -> PBftDelegationCert c
pbftIsLeaderDlgCert PBftIsLeader PBftByronCrypto
isLeader
headerGenesisKey :: Crypto.VerificationKey
VerKeyByronDSIGN headerGenesisKey = PBftDelegationCert PBftByronCrypto
-> VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
forall c.
PBftCrypto c =>
PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
dlgCertGenVerKey Certificate
PBftDelegationCert PBftByronCrypto
dlgCertificate
forge :: PBftFields PBftByronCrypto (Annotated CC.Block.ToSign ByteString)
-> ByronBlock
forge :: PBftFields PBftByronCrypto (Annotated ToSign ByteString)
-> ByronBlock
forge PBftFields PBftByronCrypto (Annotated ToSign ByteString)
ouroborosPayload = EpochSlots -> Block -> ByronBlock
annotateByronBlock EpochSlots
epochSlots Block
block
where
block :: CC.Block.Block
block :: Block
block = ABlock :: forall a. AHeader a -> ABody a -> a -> ABlock a
CC.Block.ABlock {
blockHeader :: AHeader ()
CC.Block.blockHeader = AHeader ()
header
, blockBody :: Body
CC.Block.blockBody = Body
body
, blockAnnotation :: ()
CC.Block.blockAnnotation = ()
}
headerSignature :: CC.Block.BlockSignature
headerSignature :: BlockSignature
headerSignature = Certificate -> Signature ToSign -> BlockSignature
forall a. ACertificate a -> Signature ToSign -> ABlockSignature a
CC.Block.ABlockSignature Certificate
dlgCertificate (Signature ToSign -> Signature ToSign
coerce Signature ToSign
sig)
where
sig :: Crypto.Signature CC.Block.ToSign
SignedDSIGN (SigByronDSIGN sig) = PBftFields PBftByronCrypto (Annotated ToSign ByteString)
-> SignedDSIGN
(PBftDSIGN PBftByronCrypto) (Annotated ToSign ByteString)
forall c toSign.
PBftFields c toSign -> SignedDSIGN (PBftDSIGN c) toSign
pbftSignature PBftFields PBftByronCrypto (Annotated ToSign ByteString)
ouroborosPayload
header :: CC.Block.Header
header :: AHeader ()
header = AHeader :: forall a.
Annotated ProtocolMagicId a
-> Annotated HeaderHash a
-> Annotated SlotNumber a
-> Annotated ChainDifficulty a
-> ProtocolVersion
-> SoftwareVersion
-> Annotated Proof a
-> VerificationKey
-> ABlockSignature a
-> a
-> a
-> AHeader a
CC.Block.AHeader {
aHeaderProtocolMagicId :: Annotated ProtocolMagicId ()
CC.Block.aHeaderProtocolMagicId = ProtocolMagicId -> Annotated ProtocolMagicId ()
forall b. b -> Annotated b ()
ann (AProtocolMagic () -> ProtocolMagicId
forall a. AProtocolMagic a -> ProtocolMagicId
Crypto.getProtocolMagicId (BlockConfig ByronBlock -> AProtocolMagic ()
byronProtocolMagic BlockConfig ByronBlock
cfg))
, aHeaderPrevHash :: Annotated HeaderHash ()
CC.Block.aHeaderPrevHash = HeaderHash -> Annotated HeaderHash ()
forall b. b -> Annotated b ()
ann HeaderHash
prevHeaderHash
, aHeaderSlot :: Annotated SlotNumber ()
CC.Block.aHeaderSlot = SlotNumber -> Annotated SlotNumber ()
forall b. b -> Annotated b ()
ann (SlotNo -> SlotNumber
coerce SlotNo
sno)
, aHeaderDifficulty :: Annotated ChainDifficulty ()
CC.Block.aHeaderDifficulty = ChainDifficulty -> Annotated ChainDifficulty ()
forall b. b -> Annotated b ()
ann (BlockNo -> ChainDifficulty
coerce BlockNo
bno)
, headerProtocolVersion :: ProtocolVersion
CC.Block.headerProtocolVersion = BlockConfig ByronBlock -> ProtocolVersion
byronProtocolVersion BlockConfig ByronBlock
cfg
, headerSoftwareVersion :: SoftwareVersion
CC.Block.headerSoftwareVersion = BlockConfig ByronBlock -> SoftwareVersion
byronSoftwareVersion BlockConfig ByronBlock
cfg
, aHeaderProof :: Annotated Proof ()
CC.Block.aHeaderProof = Proof -> Annotated Proof ()
forall b. b -> Annotated b ()
ann Proof
proof
, headerGenesisKey :: VerificationKey
CC.Block.headerGenesisKey = VerificationKey
headerGenesisKey
, headerSignature :: BlockSignature
CC.Block.headerSignature = BlockSignature
headerSignature
, headerAnnotation :: ()
CC.Block.headerAnnotation = ()
, headerExtraAnnotation :: ()
CC.Block.headerExtraAnnotation = ()
}
ann :: b -> Annotated b ()
ann :: b -> Annotated b ()
ann b
b = b -> () -> Annotated b ()
forall b a. b -> a -> Annotated b a
Annotated b
b ()