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

module Ouroboros.Consensus.Byron.Ledger.Forge
  ( forgeByronBlock
  , forgeRegularBlock

    -- * For testing purposes
  , forgeEBB
  ) where

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 Cardano.Ledger.Binary
  ( Annotated (..)
  , byronProtVer
  , reAnnotate
  )
import Control.Monad (void)
import Data.ByteString (ByteString)
import Data.Coerce (coerce)
import GHC.Stack
import Ouroboros.Consensus.Block
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
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
  ( LedgerSupportsMempool (..)
  , txForgetValidated
  )
import Ouroboros.Consensus.Protocol.PBFT

forgeByronBlock ::
  HasCallStack =>
  TopLevelConfig ByronBlock ->
  -- | Current block number
  BlockNo ->
  -- | Current slot number
  SlotNo ->
  -- | Current ledger
  TickedLedgerState ByronBlock mk ->
  -- | Txs to include
  [Validated (GenTx ByronBlock)] ->
  -- | Leader proof ('IsLeader')
  PBftIsLeader PBftByronCrypto ->
  ByronBlock
forgeByronBlock :: forall (mk :: MapKind).
HasCallStack =>
TopLevelConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock mk
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeByronBlock TopLevelConfig ByronBlock
cfg = BlockConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock mk
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forall (mk :: MapKind).
HasCallStack =>
BlockConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock mk
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeRegularBlock (TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
cfg)

forgeEBB ::
  BlockConfig ByronBlock ->
  -- | Current slot
  SlotNo ->
  -- | Current block number
  BlockNo ->
  -- | Previous hash
  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 HeaderHash
h) -> HeaderHash -> Either GenesisHash HeaderHash
forall a b. b -> Either a b
Right HeaderHash
h

  boundaryBlock :: CC.Block.ABoundaryBlock ()
  boundaryBlock :: ABoundaryBlock ()
boundaryBlock =
    CC.Block.ABoundaryBlock
      { boundaryBlockLength :: Int64
CC.Block.boundaryBlockLength = Int64
0 -- Used only in testing anyway
      , 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
forall a b. Coercible a b => a -> b
coerce BlockNo
curNo)
      ()
   where
    CC.Slot.EpochNumber Word64
epoch =
      EpochSlots -> SlotNumber -> EpochNumber
CC.Slot.slotNumberEpoch EpochSlots
epochSlots (SlotNo -> SlotNumber
forall a b. Coercible a b => a -> b
coerce SlotNo
curSlot)

-- | Internal helper data type for 'forgeRegularBlock' used to accumulate the
-- different kinds of block payloads that can be found in a given collection
-- of Byron 'GenTx's.
--
-- n.b. This data type is not to be exposed from this module.
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)
  -- ^ 'Just' if there is at least one 'CC.Update.Proposal' in a list of
  -- Byron 'GenTx's and 'Nothing' if there are none. It is worth noting that
  -- if we encounter multiple 'CC.Update.Proposal's in a collection of
  -- 'GenTx's, this value will be that of the last 'CC.Update.Proposal'
  -- encountered.
  }

initBlockPayloads :: BlockPayloads
initBlockPayloads :: BlockPayloads
initBlockPayloads =
  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 ->
  -- | Current block number
  BlockNo ->
  -- | Current slot number
  SlotNo ->
  -- | Current ledger
  TickedLedgerState ByronBlock mk ->
  -- | Txs to include
  [Validated (GenTx ByronBlock)] ->
  -- | Leader proof ('IsLeader')
  PBftIsLeader PBftByronCrypto ->
  ByronBlock
forgeRegularBlock :: forall (mk :: MapKind).
HasCallStack =>
BlockConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock mk
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeRegularBlock BlockConfig ByronBlock
cfg BlockNo
bno SlotNo
sno TickedLedgerState ByronBlock mk
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)
      IsLeader (PBft PBftByronCrypto)
PBftIsLeader PBftByronCrypto
isLeader
      (Version -> Annotated ToSign () -> Annotated ToSign ByteString
forall a b.
EncCBOR a =>
Version -> Annotated a b -> Annotated a ByteString
reAnnotate Version
byronProtVer (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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      Validated (GenTx ByronBlock) -> BlockPayloads -> BlockPayloads
extendBlockPayloads
      BlockPayloads
initBlockPayloads
      [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 :: BlockPayloads -> [TxAux]
bpTxs :: [TxAux]
bpTxs, [Certificate]
bpDlgCerts :: BlockPayloads -> [Certificate]
bpDlgCerts :: [Certificate]
bpDlgCerts, [Vote]
bpUpVotes :: BlockPayloads -> [Vote]
bpUpVotes :: [Vote]
bpUpVotes} =
    -- TODO: We should try to use 'recoverProof' (and other variants of
    -- 'recoverBytes') here as opposed to throwing away the serializations
    -- (the 'ByteString' annotations) with 'void' as we're currently doing.
    case Validated (GenTx ByronBlock) -> GenTx ByronBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx ByronBlock)
validatedGenTx of
      ByronTx TxId
_ ATxAux ByteString
tx -> BlockPayloads
bp{bpTxs = void tx : bpTxs}
      ByronDlg CertificateId
_ ACertificate ByteString
cert -> BlockPayloads
bp{bpDlgCerts = void cert : bpDlgCerts}
      -- TODO: We should throw an error if we encounter multiple
      -- 'ByronUpdateProposal's (i.e. if 'bpUpProposal' 'isJust').
      -- This is because we should only be provided with a maximum of one
      -- 'ByronUpdateProposal' to include in a block payload.
      ByronUpdateProposal UpId
_ AProposal ByteString
prop -> BlockPayloads
bp{bpUpProposal = Just (void prop)}
      ByronUpdateVote VoteId
_ AVote ByteString
vote -> BlockPayloads
bp{bpUpVotes = void vote : bpUpVotes}

  body :: CC.Block.Body
  body :: Body
body =
    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 mk
-> ChainHash (Ticked (LedgerState ByronBlock))
forall (l :: MapKind -> *) (mk :: MapKind).
GetTip l =>
l mk -> ChainHash l
getTipHash TickedLedgerState ByronBlock mk
st of
    ChainHash (Ticked (LedgerState ByronBlock))
GenesisHash ->
      [Char] -> HeaderHash
forall a. HasCallStack => [Char] -> a
error
        [Char]
"the first block on the Byron chain must be an EBB"
    BlockHash (ByronHash HeaderHash
h) -> HeaderHash
h

  epochAndSlotCount :: CC.Slot.EpochAndSlotCount
  epochAndSlotCount :: EpochAndSlotCount
epochAndSlotCount = EpochSlots -> SlotNumber -> EpochAndSlotCount
CC.Slot.fromSlotNumber EpochSlots
epochSlots (SlotNo -> SlotNumber
forall a b. Coercible a b => a -> b
coerce SlotNo
sno)

  toSign :: CC.Block.ToSign
  toSign :: ToSign
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
forall a b. Coercible a b => a -> b
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 VerificationKey
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 =
      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
forall a b. Coercible a b => a -> b
coerce Signature ToSign
sig)
     where
      sig :: Crypto.Signature CC.Block.ToSign
      SignedDSIGN (SigByronDSIGN Signature ToSign
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 =
      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
forall a b. Coercible a b => a -> b
coerce SlotNo
sno)
        , aHeaderDifficulty :: Annotated ChainDifficulty ()
CC.Block.aHeaderDifficulty = ChainDifficulty -> Annotated ChainDifficulty ()
forall b. b -> Annotated b ()
ann (BlockNo -> ChainDifficulty
forall a b. Coercible a b => a -> b
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 :: forall b. b -> Annotated b ()
ann b
b = b -> () -> Annotated b ()
forall b a. b -> a -> Annotated b a
Annotated b
b ()